Internet Info 1994 March

home *** CD-ROM | disk | FTP | other *** search

/ Internet Info 1994 March / Internet Info CD-ROM (Walnut Creek) (March 1994).iso / networking / terms / kermit / b / ikcutl.asm < prev next >

Wrap

Assembly Source File | 1992-09-29 | 148.9 KB | 1,883 lines

*COPY IKCUTL 05000000 CHECKVER IKCUTL,4.2 @SC90072 05000500 TITLE 'CWDSET/DSPACE Routines - set/show working directory' 05001000 * Set new 'working directory', i.e., filemode letter 05002000 * Entry: SCANPTR string has option 05003000 * Exit: R15=0 if ok, R15=1 if error or help needed. ERRNUM unchanged. 05004000 CWDSET ENTER @SC86164 05005000 * CMS filespec parts @SC86295 05006000 FN EQU FILNAM,8 @SC86295 05007000 FT EQU FN+8,8 @SC86295 05008000 FM EQU FT+8,2 @SC86295 05009000 * 05010000 IFIFM EQU IFILE+24,2 @SC90037 05013000 * 05014000 JFN EQU JFNAM,8 Foreign FN for SEND @SC86295 05015000 JFT EQU JFN+8,8 Foreign FT for SEND @SC86295 05016000 * 05017000 NTOKN N=CWDERR,H=CWDERR @SC86164 05018000 LTR 7,7 Length of token @SC86164 05019000 BNZ CWDERR >1 @SC86164 05020000 TR 0(1,6),UPCASE @SC87034 05021000 MVC IFIFM(1),0(6) Copy mode letter @SC90037 05022000 NXTFSET IFILE,CWD,E=CWDERR @SC86295 05023000 MVC DEST(1),IFIFM Save new mode @SC90037 05024000 B RTRN0 @SC86295 05025000 CWDERR PTEXT 'Must be valid CMS mode letter' @SC86295 05026000 B SUBERR @SC86295 05027000 * 05028000 * DSPACE Routine - display available disk space @SC86164 05029000 * 05030000 * Show space in 'working directory' or other minidisk 05031000 * Entry: SCANPTR string has option (none => working directory) 05032000 * Exit: R15=0 if ok, R15=1 if error or help needed. ERRNUM unchanged 05033000 DSPACE ENTER ALT @SC86164 05034000 MVC QDISK+16(1),DEST Default filemode @SC86164 05035000 NTOKN N=DSPACEX @SC86164 05036000 TR 0(1,6),UPCASE @SC87034 05037000 MVC QDISK+16(1),0(6) @SC86164 05038000 DSPACEX HOST QDISK,E=RTRN1 @SC86295 05039000 B RTRN0 @SC86295 05040000 LOCALS , @SC86295 05041000 EXIT , @SC86295 05042000 TITLE 'FSPEC Routine - extract filespec from scan string' 05043000 * 05044000 * Entry: R1->name field, R0=flags selecting operation (see below) 05045000 * For parse operations, SCANPTR defines the input string. 05046000 * For getting foreign or display filespec, R7->output buffer 05047000 * Exit: if not FFNEW, then R15=0 if ok, 1 if ?, 2 if bad. 05048000 * For R15=1 or 2 R3,R4 give message. ERRNUM may be leftover. 05049000 * 05050000 * Flags: Notes: 05051000 * Tasks: FFRCF FFSND FFGET FFNEW 05052000 * Parse RECV X set ROVR properly 05053000 * Parse SEND 1st X 05054000 * Parse SEND 2nd X X 05055000 * Parse GET 1st X 05056000 * Parse GET 2nd X X set ROVR properly 05057000 * Parse F-packet (FFHDR) X X X 05058000 * Parse for Generic(FFUTL) X X FFWLD: allow partial 05059000 * Parse TAKE 05060000 * 05061000 * Get unique name X R15: 0=>ok, 1=>bad 05062000 * Interactive name check X X R15: 0=>ok, 1=>bad 05063000 * Get foreign name (FFENC) X X R15->end of string 05064000 * Get display form (FFDSP) X X R15->end of string 05065000 * 05066000 FSPEC ENTER @SC86295 05067000 STC 0,FSPFLG @SC86295 05068000 LR 5,0 @SC88049 05068200 SRL 5,4 Convert flags to index @SC88049 05068400 AR 5,5 @SC88049 05068600 LR 0,1 Copy ptr to filespec @SC86295 05069000 TM FSPFLG,FFNEW @SC86295 05070000 BO FSPWRN @SC86295 05071000 XC 0(18,1),0(1) Clear filespec @SC86295 05072000 MVC FSPBAD(16),=C'Invalid filename' @SC86295 05073000 PTEXT FSPBAD,16 Standard msg form @SC86295 05074000 MVI ERRNUM,ERRFNE Assume bad file name @SC86158 05075000 MVC 16(2,1),DEST Default FM @SC86295 05076000 LH 5,FSP0(5) Get dispatch adr @SC88049 05077000 B FSP0(5) Go to proper handler @SC88049 05077600 * TAKE GET 1st SEND 1st Generic @SC88049 05078200 FSP0 DC AL2(FSPTAK-FSP0,FSPSN2-FSP0,FSPSND-FSP0,FSPUTL-FSP0) SC88049 05078800 * RECEIVE GET 2nd SEND 2nd F-packet @SC88049 05079400 DC AL2(FSPRC-FSP0,FSPRC-FSP0,FSPSN2-FSP0,FSPHD-FSP0) @SC88049 05080000 FSPUTL TM FSPFLG,FFWLD Utility: default to all files? @SC88049 05080600 BZ FSPASC No @SC86295 05082000 MVC 0(8,1),ASTER Yes @SC86295 05083000 MVC 8(8,1),ASTER @SC86295 05084000 FSPASC TM FL2,SRV Server mode? @SC86295 05085000 BZ FSPCPY No, don't need to convert @SC86295 05086000 ICM 15,15,LEN Get length @SC86295 05087000 BZ FSPCPY @SC86295 05088000 BCTR 15,0 Correct for EX @SC86158 05089000 L 5,ADR Get string ptr @SC89215 05090000 EX 15,FSPTRAE Change to EBCDIC @SC89215 05091000 EX 15,FSPTRUP Upcase and dot to space @SC89215 05092000 B FSPCPY @SC86295 05095000 FSPTRAE TR 0(,5),ATOED @SC89301 05096000 FSPTRUP TR 0(,5),FSPUPDOT @SC89215 05097000 FSPRC NI FL1,255-ROVR Setup for RECEIVE @SC86295 05100000 NI FL4,255-NMOK-NMCHNG Collision not checked yet @SC90033 05101000 MVI 0(1),C'$' Default FN @SC86295 05102000 MVC UFM,DEST Default FM, can change by = = x @SC86295 05103000 B FSPCPY @SC86295 05104000 FSPHD MVC 0(8,1),=CL8'$' Default fn @SC86295 05105000 MVC 8(8,1),0(1) Default ft @SC86295 05106000 MVC 16(2,1),UFM Default fm @SC86295 05107000 L 2,ADR @SC86295 05108000 TR 0(256,2),FSPTAB Make valid fn chars @SC86295 05109000 B FSPCPY @SC86295 05110000 FSPSND TM FL5,SALL @SC88049 05113000 BZ *+10 @SC86295 05114000 MVC 16(2,1),ASTER Default FM for SEND @SC86295 05115000 B FSPASC @SC86295 05116000 FSPSN2 MVI 1(1),C'=' Foreign file name is same @SC86295 05117000 MVI 9(1),C'=' @SC86295 05118000 CTOKN NODOT,H=FSP2H,N=RTRN0 @SC89097 05119000 LA 1,L'JFNAM @SC86295 05120000 CLM 7,3,*-2 Does it fit? @SC86224 05121000 BNH *+6 Yes @SC86224 05122000 LR 7,1 Use what we can @SC86224 05123000 LR 3,0 @SC86295 05124000 STC 7,0(3) Save length @SC86224 05125000 LA 0,1(3) @SC86295 05126000 MVCL 0,6 Get fn, at least @SC86224 05127000 MVI TRTBL+C'.',2 See if valid CMS token @SC86224 05128000 MVI TRTBL+C'/',2 @SC86224 05129000 SR 2,2 @SC86224 05130000 TRT 1(9,3),TRTBL @SC86295 05131000 MVI TRTBL+C'.',0 @SC86224 05132000 MVI TRTBL+C'/',0 @SC86224 05133000 BCT 2,RTRN0 Not valid: must be complex string @SC86224 05134000 MVC FSPPTR,SCANPTR @SC86295 05135000 LA 2,3 @SC86295 05136000 FSPCNT CLI BRK,C',' @SC88306 05137000 BE FSPCNZ Take comma as end @SC88306 05137300 NTOKN N=FSPCNZ @SC88306 05137600 BCT 2,FSPCNT @SC86295 05138000 FSPCNZ MVC SCANPTR,FSPPTR Restore ptrs @SC86295 05139000 N 2,F1 @SC86295 05140000 BNZ RTRN0 Single token string @SC86295 05141000 LA 0,9(3) Get 2nd token @SC86295 05142000 MVI 0(3),0 Clear length again @SC86295 05143000 MVC FSPBADX,=C'type' @SC86295 05144000 CTOKN NOBRK,H=FSP2H,N=FSPMIS @SC89097 05145000 MVCL 0,6 @SC86295 05146000 B RTRN0 @SC86295 05147000 FSPTAK TM FSPFLG,FFGIV GIVE command? @SC88049 05150000 BO *+10 Yes, keep specific FM @SC87117 05151000 MVC 16(2,1),ASTER Default FM for TAKE @SC86295 05152000 MVC 8(8,1),=CL8'TAKE' @SC86295 05153000 FSPCPY LA 5,LFID(,1) Point to file options @SC89218 05154000 CTOKN NOBRK,H=FSPH,N=FSPZ,OPTS=0 @SC89218 05154500 TM FSPFLG,FFRCF @SC86295 05155000 BZ FSPCPN @SC86295 05156000 CLI 0(6),C'=' @SC86224 05157000 BE FSPREQ Go if RECEIVE = ... @SC86295 05158000 CLI 0(6),C'*' @SC86224 05159000 BE FSPINV @SC86295 05160000 FSPCPN BAL 14,FSPTOK Get fn @SC87034 05161000 MVC FSPBADX,=C'type' @SC86295 05162000 CTOKN H=FSPH,N=FSPZ,OPTS=FSPZ @SC89218 05163000 CLI 0(6),C'=' @SC86224 05164000 BE FSPINV Go if RECEIVE xxx = @SC86295 05165000 TM FSPFLG,FFRCF @SC86295 05166000 BZ FSPCPT @SC86295 05167000 CLI 0(6),C'*' @SC86224 05168000 BE FSPINV Go if RECEIVE xxx * @SC86295 05169000 OI FL1,ROVR Overwrite received fname @SC86295 05170000 FSPCPT BAL 14,FSPTOK Get ft @SC87034 05171000 MVC FSPBADX,=C'mode' @SC86295 05174000 CTOKN FM,H=FSPH,N=FSPZ,OPTS=FSPZ @SC89218 05175000 TM FSPFLG,FFRCF @SC86295 05176000 BZ FSPCPM @SC86295 05177000 CLI 0(6),C'*' @SC86224 05178000 BE FSPINV @SC86295 05179000 FSPCPM DS 0H @SC89097 05180000 BAL 14,FSPTOK Get fm @SC87034 05181000 B RTRN0 @SC86295 05182000 * 05183000 FSPREQ MVC FSPBADX,=C'type' @SC86295 05184000 CTOKN H=FSPH,N=FSPZ,OPTS=FSPZ Get ft for RECEIVE = @SC89218 05185000 CLI 0(6),C'=' @SC86224 05186000 BNE FSPINV Go if FT is not = @SC86295 05187000 CLI 0(6),C'*' @SC86224 05188000 BE FSPINV Bad FM @SC86295 05189000 MVC FSPBADX,=C'mode' @SC86295 05190000 CTOKN FM,H=FSPH,N=FSPZ,OPTS=FSPZ Pick fm @SC89218 05192000 BAL 14,FSPTOK Use FM they specified @SC87034 05193000 MVC UFM,0(1) Use for all of file group @SC87034 05194000 B RTRN0 @SC87034 05195000 * 05196000 FSPTOK LR 8,0 Save start @SC87034 05197000 LR 9,1 And length @SC87034 05198000 MVCL 0,6 Copy token with padding @SC87034 05199000 LR 1,8 @SC87034 05200000 BCTR 9,0 Fix for TR @SC87034 05201000 EX 9,TRUPCAS Upcase the token @SC87034 05202000 BR 14 @SC87034 05203000 * 05203050 FSPDOTS LTR 1,7 Copy length-1 @SC89097 05203100 BNPR 14 Can't convert if just '.' @SC89097 05203150 LR 9,6 Copy start of token @SC89097 05203200 FSPDOTL CLI 1(9),C'.' Scan for '.', if any @SC89097 05203250 BE FSPDOTF Found one @SC89097 05203300 LA 9,1(,9) Keep looking @SC89097 05203350 BCT 1,FSPDOTL @SC89097 05203400 BR 14 Not found, ordinary token @SC89097 05203450 FSPDOTF LR 7,9 Found dot: break up token @SC89097 05203500 SR 7,6 Length-1 of stuff before dot @SC89097 05203550 LM 8,9,SCANPTR @SC89097 05203600 SR 9,1 Back up over brk + post-dot stuff @SC89097 05203650 AR 8,1 ... and increase length left @SC89097 05203700 STM 8,9,SCANPTR @SC89097 05203750 MVI BRK,C' ' Reset separator too @SC89218 05203770 BR 14 @SC89097 05203800 * 05204000 FSPZ LR 14,0 @SC86295 05205000 CLI 0(14),C' ' Any default given? @SC86295 05206000 BH RTRN0 Yes, use it @SC86295 05207000 FSPMIS MVC FSPBAD,=C'Missing' @SC86295 05208000 FSPINV LA 15,2 @SC86295 05209000 B FSPPTRS @SC86295 05210000 * 05211000 FSPH PTEXT 'Filespec has format: fn ft [fm][<first-last>]' @SC89261 05212000 CLI FSPFLG,FFSND SEND 1st? @SC89261 05212200 BE *+8 Yes, use whole message @SC89261 05212400 SH 4,=H'14' Chop off option part @SC89261 05212600 B FSP0H @SC86295 05213000 FSP2H PTEXT 'Enter foreign filespec' @SC86295 05214000 FSP0H LA 15,1 @SC86295 05215000 FSPPTRS RETREG 3,4 Return msg ptrs @SC86295 05216000 FSPRET RET , @SC86295 05218000 * 05219000 * Non-parsing functions . . . 05220000 * 05221000 * Get unique filespec 05222000 FSPWRN LR 4,1 Save name ptr @SC86295 05223000 TM FSPFLG,FFENC @SC86295 05224000 BO FSPENC Encode name into buffer @SC86295 05225000 TM FSPFLG,FFDSP @SC86295 05226000 BO FSPDSP Copy name into buffer for display @SC86295 05227000 TM FL4,NMOK Already checked? @SC87012 05228000 BO RTRN0 Yes, ok @SC87012 05229000 MVC XFILE,0(1) Save original name @SC90033 05229500 LA 6,8+6(1) End of FT @BS86001 05230000 BCTR 6,0 @BS86001 05231000 CLI 0(6),C' ' Find end of token @BS86001 05232000 BE *-6 @BS86001 05233000 LA 5,10+1 Allowed retries @BS86001 05234000 LA 7,C'0' Extra character @BS86001 05235000 OI FL4,NMOK Assume it checks @SC87012 05236000 FSPSTA OPENF T,(4),E=RTRN0 Does it exist already? @SC86135 05237000 OI FL4,NMCHNG Yes, remember collision occurred @SC90033 05237500 MVI 1(6),C'$' Yes, modify FT @BS86001 05238000 STC 7,2(6) Serialize @BS86001 05239000 LA 7,1(7) Bump counter @BS86001 05240000 BCT 5,FSPSTA @BS86001 05241000 PTEXT 'Filename collision' @SC88049 05242000 B FSP0H Return error code @SC88049 05242500 * 05243000 * Encode name at (R1) into (R7) buffer (in ASCII), possibly with 05244000 * substitution from JFSPEC, but disable subsequent subst. 05245000 * Return updated ptr in R15 05246000 FSPENC LA 1,JFSPEC Complex string? @SC86224 05247000 LA 5,JFNAM Remote file-spec @SC86155 05248000 BAL 14,PAKFOR @SC86224 05249000 BNZ FSPFILS Yes, tokens aren't used @SC86224 05250000 BAL 14,FSPFID Filename @HF86223 05251000 LA 7,1(7) Skip over period @HF86223 05252000 BAL 14,FSPFID Filetype @HF86223 05253000 FSPFILS MVI JFSPEC,0 Turn off string @SC86224 05254000 CLI JFN,C'=' Partial renaming? @SC86224 05255000 BE FSPENR Yes, keep it @SC86224 05256000 CLI JFT,C'=' @SC86224 05257000 BE FSPENR @SC86224 05258000 MVI JFN,C'=' Now use original name @SC86171 05259000 MVI JFT,C'=' @SC86171 05260000 FSPENR LR 15,7 Save ptr @SC86295 05261000 B FSPRET @SC86295 05262000 * 05263000 * Copy name at (R1) into (R7) buffer in display form 05264000 * Return updated ptr in R15 05265000 FSPDSP BAL 14,FSPDTK Filename @SC86295 05266000 BAL 14,FSPDTK Filetype @SC86295 05267000 MVC 0(2,7),0(4) Filemode @SC86295 05268000 LA 7,2(7) @SC86295 05269000 B FSPENR @SC86295 05270000 * 05271000 * Subroutine to detokenize a list into ASCII @SC86135 05272000 FSPFID MVC 0(8,7),0(4) Copy token @SC86135 05273000 CLI 0(5),C'=' Keep true name? @SC86171 05274000 BE *+10 Yes @SC86171 05275000 MVC 0(8,7),0(5) No, use override @SC86171 05276000 LA 1,8(7) End of token if no blanks @SC86135 05277000 TRT 0(8,7),TRTBL Find 1st blank @SC86135 05278000 TR 0(8,7),ETOAD ASCII it @SC89301 05279000 LR 7,1 New end of string @SC86135 05280000 LA 4,8(4) Next token @SC86135 05281000 LA 5,8(5) @SC86171 05282000 MVI 0(7),ADOT Add an ASCII dot, just in case @SC86135 05283000 BR 14 @SC86135 05284000 * 05285000 * Subroutine to detokenize a list in EBCDIC @SC86295 05286000 FSPDTK MVC 0(8,7),0(4) Copy token @SC86135 05287000 LA 1,8(7) End of token if no blanks @SC86135 05288000 TRT 0(8,7),TRTBL Find 1st blank @SC86135 05289000 MVI 0(1),C' ' Add a BLANK @SC86295 05290000 LA 7,1(1) New end of string @SC86135 05291000 LA 4,8(4) Next token @SC86135 05292000 BR 14 @SC86135 05293000 * 05294000 * Subroutine to set up CMS token for copying @SC86224 05295000 CMSTOK8 LA 7,1(7) @SC86224 05296000 ICM 7,8,BLANK @SC86224 05297000 LA 1,8 @SC86224 05298000 BR 14 @SC86224 05299000 * 05300000 * Table to convert EBCDIC text to upper case + dot to blank @SC89215 05300100 FSPUPDOT DC (C'.')AL1(*-FSPUPDOT) @SC89215 05300200 DC C' ' @SC89215 05300300 DC (127-C'.')AL1(*-FSPUPDOT) @SC89215 05300400 HTBL 80,C1,C2,C3,C4,C5,C6,C7,C8,C9,8A,8B,8C,8D,8E,8F @SC89268 05300500 HTBL 90,D1,D2,D3,D4,D5,D6,D7,D8,D9,9A,9B,9C,9D,9E,9F @SC89268 05300600 HTBL A0,A1,E2,E3,E4,E5,E6,E7,E8,E9,AA,AB,AC,AD,AE,AF @SC89268 05300700 DC 080AL1(*-FSPUPDOT) @SC89215 05300800 * Valid CMS file name characters @SC86295 05301000 FSPTAB DC 64C'_',C' ' space @SC86295 05302000 DC 10C'_',C' ' dot @SC86295 05303000 DC 02C'_',C'+' plus @SC86295 05304000 DC 12C'_',C'$' dollar sign @SC86295 05305000 DC 04C'_',C'-' dash @SC86295 05306000 DC 12C'_',C'_' underscore @SC86295 05307000 DC 12C'_',C':#@' colon, pound sign, at sign@SC86295 05308000 DC 04C'_',C'ABCDEFGHI' a-i @SC86295 05309000 DC 07C'_',C'JKLMNOPQR' j-r @SC86295 05310000 DC 08C'_',C'STUVWXYZ' s-z @SC86295 05311000 DC 23C'_',C'ABCDEFGHI' A-I @SC86295 05312000 DC 07C'_',C'JKLMNOPQR' J-R @SC86295 05313000 DC 08C'_',C'STUVWXYZ' S-Z @SC86295 05314000 DC 06C'_',C'0123456789' 0-9 @SC86295 05315000 DC 06C'_' @SC86295 05316000 LOCALS , @SC86295 05317000 FSPBAD DS C'Invalid',C' file' @SC86295 05318000 FSPBADX DS C'name' @SC86295 05319000 FSPPTR DS XL8 Saved scan ptrs @SC86295 05320000 FSPFLG DS X Filespec flags @SC86295 05321000 FSPEC EXIT @SC86295 05322000 TITLE 'KHELP routine - perform HELP command' 05323000 * Handle HELP command, rest of string given by SCANPTR. 05324000 KHELP ENTER , @SC86355 05325000 * CMS version ignores any extra operands on HELP command @SC86355 05326000 LA 2,KRMNAM Ptr to original command name @SC88049 05327000 CLI 0(2),C'*' Was it a START? @SC86355 05328000 BE KHLDF Yes, use default @SC86355 05329000 CLI 0(2),X'FF' Nothing at all? @SC86355 05330000 BNE KHLI Something, use it @SC87007 05331000 KHLDF LA 2,=CL8'KERMIT' @SC86355 05332000 KHLI LA 1,CMD Command buffer @SC87007 05333000 MVC 0(5,1),=CL5'HELP' @SC86355 05334000 MVC 5(30,1),0(2) Copy operand @SC86355 05335000 LA 0,5+8 Length of command @SC86355 05336000 STM 0,1,SCANPTR Set up for system @SC86355 05337000 OI FL4,UCMD @SC86355 05338000 KCALL SUPFNC,3 Do it @SC86355 05339000 RET , @SC86355 05340000 LOCALS , 05341000 KHELP EXIT , @SC87007 05342000 TITLE 'SUPFNC Routine - various supervisor functions' @SC86158 05343000 SUPFNC ENTER @SC86295 05344000 * On entry, R1 = operation code, R0 = possible ptr @SC86158 05345000 * Exit: R15 set (0 => ok, <0 => illegal cmd, >0 => depends) 05346000 * ERRNUM set appropriately (R1=1,3,4) or unchanged (2,5-11) 05347000 * 1 -> Start typeout interception. N.B. &MAXLR >> 2048 for this 05348000 * 2 -> Clean up afterwards and stop interception 05349000 * 3 -> Execute host command with or without interception 05350000 * If UCMD set, SCANPTR gives text, else R0->text,R6=len 05351000 * 4 -> Execute CP command with or without interception 05352000 * R0->text, R6=len 05353000 * 5 -> Stop interception if going 05354000 * 6 -> Retrieve original cmd parm string into CBUF (R15=1 if null) 05355000 * 7 -> Test for stacked lines, return number in R15 05356000 * 8 -> Log off (doesn't return!) 05357000 * 9 -> Wait specified time 05358000 * 10-> Return clock time in R15 (centisec) 05359000 * 11-> Setup up new prompt string at (R0) 05360000 BCT 1,ICPFIN @SC86158 05361000 * Start interception, initialize ptrs @SC86158 05362000 MVI ERRNUM,ERRNOE OK @SC86158 05363000 LA 0,2048 Suitable offset @SC86158 05364000 A 0,WBUF Output buffer @SC86158 05365000 L 1,TSENT Limit @SC86158 05366000 LR 15,0 @SC86158 05367000 STM 15,0,TXTPTR Save @SC86158 05368000 STM 0,1,SVCOPTR @SC86158 05369000 SR 1,0 Get length @SC86158 05370000 L 15,=X'15000000' @SC86158 05371000 MVCL 0,14 Fill with NL (X'15') @SC86158 05372000 MVI SVCSNAG+1,0 370-mode PSW @SC89235 05372100 LA 14,SVCOPSW+3 Assume page 0 version @SC89235 05372200 TM FLGXA,XACMS XA mode? @SC89235 05372300 BZ SFCSVCST No, fine @SC89235 05372400 MVI SVCSNAG+1,X'08' XA-mode PSW @SC89235 05372500 AIF ('&KTAG' NE 'XA').CMSXA1 @SC90067 05372550 L 1,ASVCSECT Ptr to SVC info @SC89235 05372600 USING SVCSECT,1 @SC89235 05372700 LA 14,SVCOCODE Use XA version @SC89235 05372800 .CMSXA1 ANOP @SC90067 05372850 SFCSVCST ST 14,SVCOCPTR Correct ptr to SVC code @SC89235 05372900 CLC SVCNPSW,SVCSNAG Already set up? @SC86158 05373000 BE RTRN0 Yes, but how? @SC86295 05374000 MVC SAVENPSW,SVCNPSW @SC86158 05375000 MVC TYPSAV,ADMSCWR @SC86283 05376000 DMSKEY NUCLEUS @SC86283 05377000 MVC SVCNPSW,SVCSNAG Set up interception (SVC) @SC86283 05378000 MVC ADMSCWR,=A(ICPTYP) (BALR) @SC86283 05379000 DMSKEY RESET @SC86283 05380000 B RTRN0 @SC86295 05381000 * Clean up after interception @SC86295 05382000 ICPFIN BCT 1,ICPHST @SC86158 05383000 L 5,SVCOPTR End of text @SC86158 05384000 ST 5,TXTPTR+4 Save @SC86158 05385000 B ICPRST1 Now restore interrupts @SC86295 05386000 * Restore SVC interrupt vector @SC86158 05387000 ICPRST BCT 1,SFCLIN @SC86295 05388000 ICPRST1 CLC SVCNPSW,SVCSNAG @SC86295 05389000 BNE RTRN0 OK @SC86295 05390000 DMSKEY NUCLEUS @SC86283 05391000 MVC SVCNPSW,SAVENPSW @SC86283 05392000 MVC ADMSCWR,TYPSAV @SC86283 05393000 NI MSGFLAGS,255-NOTYPING @SC88309 05393500 DMSKEY RESET @SC86283 05394000 B RTRN0 05395000 * Avoid user-area CMS commands, otherwise execute command at @SC86158 05396000 * (R0) already tokenized. Save return code. @SC86158 05397000 ICPHST BCT 1,ICPCP @SC86158 05398000 TM FL4,UCMD User CMS command? @SC86295 05399000 BZ ICPCMS0 No, already tokenized @SC86295 05400000 LM 0,1,SCANPTR @SC86295 05401000 LTR 15,0 @SC87034 05402000 BNP ICPCMIL Nothing there @SC87034 05403000 DMSKEY NUCLEUS Enter Key 0 @SC86295 05406000 L 15,ASCANN @SC86295 05407000 BALR 14,15 Tokenize data @SC86295 05408000 LR 3,0 Length of tokenized list @SC90073 05408200 BCTR 3,0 Get length for TR @SC90073 05408400 EX 3,TRUPCAS Convert to upper case @SC90073 05408600 LR 0,15 @SC86295 05409000 DMSKEY RESET Restore user key @SC86295 05410000 LTR 15,0 Did SCANN fail? @SC86295 05411000 BNZ ICPCMIL Yes @SC86295 05412000 C 3,F8 Did we get anything? @SC90073 05412300 BNH ICPCMIL No, just a fence. Give up @SC90073 05412600 LR 0,1 @SC86295 05413000 ICPCMS0 LR 3,0 @SC86295 05414000 CLC =C'CP ',0(3) CP command? @SC86158 05415000 BE ICPCMSCP Yes, do it @SC86158 05416000 MVI TRTBL+C'%',1 Possible wildcard chars @SC90037 05416100 MVI TRTBL+C'*',1 @SC90037 05416200 TRT 0(8,3),TRTBL See if any % or * in FN @SC90037 05416300 MVI TRTBL+C'%',0 Restore TRTBL @SC90037 05416400 MVI TRTBL+C'*',0 @SC90037 05416500 BZ *+12 No wild chars found @SC90037 05416600 CLI 0(1),C' ' Maybe just a blank? @SC90037 05416700 BNE ICPCMIL No, illegal @SC90037 05416800 MVC IFT,=CL8'EXEC' @SC86158 05417000 MVC IFM,ASTER Search all disks @SC86158 05418000 TM OPTFLAGS,NOIMPEX EXEC's allowed? @SC86158 05419000 BO ICPCMSM No, try for module @SC86158 05420000 TM FL4,UCMD User CMS command? @SC86158 05421000 BZ ICPCMSM No, avoid EXEC's @SC86158 05422000 ICPCMSA MVC IFN,0(3) @SC86158 05423000 LA 4,1 @SC86158 05424000 ICPCMSS FSSTATE FSCB=IFSCB,ERROR=ICPABBR See if exists @SC90037 05425000 LR 5,1 @SC86295 05427000 USING FSTSECT,5 @SC90037 05428000 DMSEXS MVC,0(8,3),IFN Found, copy full name @SC86158 05431000 CLI IFT,C'E' EXEC? @SC86158 05432000 BNE ICPCMSU No, module. Check it @SC86158 05433000 S 3,F8 Back up to EXEC in COMBUF @SC86158 05434000 DMSEXS MVC,NUCPLBEG,NUCPLCMD Argst begins w/ cmd name @SC89264 05434500 B ICPCMSX Do it @SC86158 05435000 ICPABBR LTR 4,4 Already tried abbrev? @SC86158 05436000 BZ ICPCMSM Yes, give up @SC86158 05437000 TM OPTFLAGS,NOABBREV Allowed? @SC86158 05438000 BO ICPCMSM No, just do it @SC86158 05439000 DMSKEY NUCLEUS @SC86158 05440000 LM 0,1,0(3) Get name entered @SC86158 05441000 L 15,AABBREV Look up abbreviation @SC86158 05442000 BALR 14,15 @SC86158 05443000 LR 4,15 Save RC @SC86158 05444000 DMSKEY RESET Return to normal @SC86158 05445000 LTR 4,4 Did we find one? @SC86158 05446000 BNZ ICPCMSM No, give up @SC86158 05447000 STM 0,1,IFN Yes, try it @SC86158 05448000 B ICPCMSS Now R4=0, don't loop @SC86158 05449000 ICPCMSM CLI IFT,C'M' @SC86158 05450000 BE ICPCMEX Already looked @SC90037 05451000 MVC IFT,=CL8'MODULE' @SC86158 05452000 B ICPCMSA Start over again @SC86158 05453000 ICPCMEX CLC =CL8'EXEC',IFN Are we looking for an EXEC? @SC90037 05453600 BNE ICPCMSX No, just execute it @SC90037 05453900 MVC IFN,8(3) Yes, see if it exists @SC90037 05454200 MVC IFT,=CL8'EXEC' @SC90037 05454500 FSSTATE FSCB=IFSCB,ERROR=ICPCMIL See if exists @SC90037 05454800 B ICPCMSX @SC90037 05455100 ICPCMSU CLI FSTFV,C'F' System-key transient? @SC90037 05455400 BE ICPCMSX OK, no problem @SC86158 05456000 MVC IFM,FSTM Get right mode letter @SC86158 05457000 DROP 5 @SC90037 05457500 LA 2,CMD Buffer for 1st record of module @SC86295 05458000 MVC 4(4,2),=A(KERMIT) In case of failure @SC86295 05459000 FSREAD FSCB=IFSCB,BUFFER=(2) Get header record @SC86295 05461000 FSCLOSE FSCB=IFSCB @SC86158 05462000 CLC =A(KERMIT),CMD+4 Check beginning adr @SC86158 05463000 BH ICPCMSX Below Kermit, assume it's ok @SC89023 05463300 CLC =XL4'20000',=A(KERMIT) Are we both user-area? @SC89023 05463600 BNH ICPCMIL User-area, forbid it @SC86158 05464000 ICPCMSX HOST 0(3),E=*+4,EPL=YES Accept errors, use ext.PL. @SC89264 05465000 LTR 6,15 Save return code @SC86295 05466000 BNM SFCRC @SC86295 05467000 TM OPTFLAGS,NOIMPCP @SC86295 05468000 BO ICPCMIL No implied CP commands @SC86295 05469000 TM FL4,UCMD User command? @SC86295 05470000 BO ICPCMSCP Yes, maybe it's for CP @SC86295 05471000 ICPCMIL MVI ERRNUM,ERRSYS Illegal system command @SC86295 05472000 B RTRNM1 @SC86295 05473000 ICPCMP CLC 1(,4),0(3) Partial token matching @SC86158 05474000 IFSCB FSCB 'X X',BSIZE=80,RECNO=1,RECFM=V @SC86158 05475000 IFN EQU IFSCB+8,8 @SC90037 05475200 IFT EQU IFN+8,8 @SC90037 05475400 IFM EQU IFT+8,2 @SC90037 05475600 * Execute CP command sent to CMS (assumed SCANN'ed) @SC86158 05476000 ICPCMSCP L 0,NUCPLCMD Get cmd ptr @SC86158 05477000 L 6,NUCPLEND @SC86158 05478000 SR 6,0 Get length @SC86158 05479000 LA 1,1 Simulate normal entry @SC86158 05480000 * Execute CP command at (R0) with text interception @SC86158 05481000 ICPCP BCT 1,ICPRST @SC86158 05482000 LR 1,0 Copy ptr for upcasing @SC87034 05483000 LTR 4,6 @SC87034 05484000 BNP ICPCMIL Nothing there @SC87034 05485000 BCTR 4,0 @SC87034 05486000 EX 4,TRUPCAS @SC87034 05487000 CLC SVCNPSW,SVCSNAG @SC86283 05488000 BNE ICPCDG Not intercepting, just do it @SC86283 05489000 KCALL SETMSG,3 Restore CP settings @SC86158 05490000 LM 1,2,SVCOPTR Response buffer @SC86158 05491000 SR 2,1 Get buffer length @SC86158 05492000 L 7,=F'8192' Max length from CP @SC86158 05493000 CR 7,2 Do we have that much? @SC86158 05494000 BNH *+6 @SC86158 05495000 LR 7,2 Use what we have @SC86158 05496000 LR 2,7 Remember @SC86158 05497000 ICM 6,8,BLANK @SC86158 05498000 DIAG 0,6,8 Issue command @SC86158 05499000 BZ *+6 @SC86158 05500000 LR 7,2 Not likely: filled buffer @SC86158 05501000 A 7,SVCOPTR @SC86158 05502000 BCTR 7,0 Scan back over any extra X'15' @SC86158 05503000 CLI 0(7),X'15' @SC86158 05504000 BE *-6 @SC86158 05505000 LA 7,2(7) Keep one X'15' @SC86158 05506000 C 7,SVCOPTR+4 Be careful of end @SC86158 05507000 BNH *+8 OK @SC86158 05508000 L 7,SVCOPTR+4 Got past it somehow @SC86158 05509000 ST 7,SVCOPTR @SC86158 05510000 KCALL SETMSG,2 Change CP settings again @SC86158 05511000 B ICPRC @SC86295 05512000 * 05513000 ICPCDG DIAG 0,6,8 Issue command @SC86283 05514000 ICPRC C 6,F1 Illegal command? @SC86295 05515000 BE ICPCMIL Yes @SC86295 05516000 * Issue return code msg if needed @SC86295 05517000 SFCRC LTR 4,6 Check RC @SC86295 05518000 BZ SFCZRC RC=0 @SC86158 05519000 TM FL4,UCMD User cmd? @SC86316 05520000 BZ SFCZRC No, don't issue message @SC86316 05521000 MVC CMD(2),=C'R(' Set up message @SC86209 05522000 LA 15,CMD+2 @SC86209 05523000 BAL 2,EDDEC Edit RC into msg @SC86295 05524000 MVI 0(15),C')' Format is R(rc) @SC86209 05525000 LA 0,1(15) @SC86268 05526000 LA 1,CMD Start of edited string @SC86209 05527000 SR 0,1 Length @SC86268 05528000 WTEXT (1),(0) @SC86268 05529000 SFCZRC LR 15,6 @SC86295 05530000 MVI ERRNUM,ERRNOE No errors @SC86295 05531000 B RTRN @SC86295 05532000 * 05533000 SFCLIN BCT 1,SFCSTK @SC86295 05534000 * Retrieve original command line arguments, if any @SC86295 05535000 * Return code =0 if yes, =1 if no @SC86295 05536000 * Leave string in CBUF buffer (up to 512), length in CLEN @SC89235 05537000 LM 5,6,ORGR0 Original R0,R1 @SC87253 05538000 CLI 0(6),255 @SC86171 05539000 BE RTRN1 Go if, e.g., just 'START' @SC86171 05540000 LA 6,8(6) Ok, point to arguments @SC86171 05541000 CLI 0(6),255 @SC86171 05542000 BE RTRN1 Go if nothing on cmd 05543000 L 8,CBUF A safe data area @SC89235 05544000 LA 9,512 Length of buffer @SC89235 05544500 CLI ORGR1,1 @SC87253 05545000 BL SFCCMDK R1 hi order byte is 0 05546000 CLI ORGR1,11 @SC87253 05547000 BH SFCCMDK R1 hi order byte is > X'0B' 05548000 LM 6,7,4(5) Address of arguments, end @SC89235 05549000 SR 7,6 Get length @SC89235 05549500 CR 9,7 How much info? @SC89235 05550000 BNH *+6 Ok @SC89235 05550500 LR 9,7 Copy only what's there @SC89235 05551000 ST 9,CLEN Save command length @SC89235 05551500 MVCL 8,6 @SC89235 05552000 B RTRN0 @SC89235 05552500 * 05554000 SFCCMDK AR 9,8 Ptr to end of buffer @SC89235 05555000 SFCCMDKL MVC 0(8,8),0(6) Copy token @SC89235 05555700 LA 1,8(,8) Char after token @SC89235 05556400 TRT 0(8,8),TRTBL Find blank @SC89235 05557100 MVI 0(1),C' ' Add a blank, in case @SC86295 05558000 LA 8,1(,1) Skip over blank @SC89235 05559000 LA 6,8(6) Skip a CMS token 05560000 CLI 0(6),255 05561000 BE SFCCMDKM End of str, quit copying @SC89235 05562000 CR 8,9 Is it too long? @SC89235 05563000 BL SFCCMDKL Loop if more room @SC89235 05564000 SFCCMDKM S 8,CBUF Length = current pos - beginning @SC89235 05565000 ST 8,CLEN Save command length @SC89235 05566000 B RTRN0 @SC86295 05568000 * 05569000 * Test for stacked commands @SC86295 05570000 * return code = number of stacked lines @SC86295 05571000 SFCSTK BCT 1,SFCKIL @SC86295 05572000 LH 15,NUMFINRD Pending lines @SC86295 05573000 A 15,NUCNLSTK Lines in program stack @SC86295 05574000 B RTRN @SC86295 05575000 * 05576000 * Log out @SC86295 05577000 SFCKIL BCT 1,SFCWT @SC86295 05578000 CPCMD 1,0,'LOGOFF' @SC86295 05579000 * 05580000 * Wait specified time in R0 (sec) 05581000 SFCWT BCT 1,SFCCLK @SC86295 05582000 LINEDIT TEXT='SL ..... SEC',DOT=NO,DISP=CPCOMM, +05583000 SUB=(DEC,(0)) @SC86184 05584000 B RTRN0 @SC86295 05585000 * 05586000 * Return time in centisec in R15 05587000 SFCCLK BCT 1,SFCPRP @SC87351 05588000 STCK TMPDW Store TOD clock @SC86295 05589000 LM 14,15,TMPDW @SC86295 05590000 SLDL 14,8 Take mod 204 days @SC86295 05591000 SRDL 14,20 Get in microsec @SC86295 05592000 D 14,=F'10000' Get in centisec @SC86295 05593000 B RTRN @SC86295 05594000 * 05595000 * Set up prompt string @SC89334 05596000 SFCPRP ICM 4,1,S1HND See if handshake is defined @SC89334 05596050 BZ RTRN0 No, skip it @SC89334 05596100 LR 1,0 Ptr to prompt string @SC89334 05596150 BCTR 1,0 Ptr to prompt string length @SC89334 05596200 SR 2,2 @SC89334 05596250 ICM 2,1,0(1) Get length @SC89334 05596300 BZ RTRN0 No prompt, leave it to system @SC89334 05596350 LA 3,0(2,1) Point to last character @SC89334 05596400 CLM 4,1,0(3) Is it the handshake? @SC89334 05596450 BE RTRN0 Yes, assume all is well @SC89334 05596500 STC 4,1(,3) No, tack one onto string @SC89334 05596550 LA 2,1(,2) And update length @SC89334 05596600 STC 2,0(,1) @SC89334 05596650 B RTRN0 @SC89334 05596700 TITLE 'SVC interceptor, executed in system protect key' 05597000 USING ICPTYP,15 @SC86283 05598000 ICPTYP STM 12,14,SVCSV1 Save regs @SC86283 05599000 L 13,SVCSNAG+4 Addressability @SC86283 05600000 DROP 15 05601000 USING SVCEXIT,13 @SC86283 05602000 B ICPTGO Grab it @SC86283 05603000 SVCEXIT STM 12,13,0 Save regs @SC86158 05604000 BALR 13,0 Addressability @SC86158 05605000 USING *,13 @SC86158 05606000 L 13,SVCSNAG+4 Addressability @SC86283 05607000 USING SVCEXIT,13 @SC86283 05608000 ICM 13,8,SVCEXIT Flag for SVC entry @SC86283 05609000 MVC SVCSV1(8),0 @SC86158 05610000 STM 14,15,SVCSV2 @SC86158 05611000 L 12,AFVS @SC86158 05612000 USING FVSECT,12 @SC86158 05613000 TM UFDBUSY,ABNBIT ABEND in progress? @SC86158 05614000 BO SVCCNCL @SC86158 05615000 L 14,SVCOCPTR Correct ptr to SVC code @SC89235 05616000 CLI 0(14),13 ABEND? @SC89235 05616500 BE SVCCNCL @SC86158 05617000 CLI 0(14),203 @SC89235 05618000 BE SVC203T Could be DMSABN @SC86158 05619000 CLI 0(14),204 Used only in CMS 5.5 and above @SC89235 05619300 BE *+12 @SC89235 05619600 CLI 0(14),202 @SC89235 05620000 BNE SVCGO Ok, do it @SC86158 05621000 CLC =CL8'TYPLIN',0(1) WRTERM? @SC86158 05622000 BNE SVCGO No, do it @SC86158 05623000 ICPTGO LM 14,15,SVCOPTR Output ptrs @SC86158 05624000 SR 15,14 Length left @SC86158 05625000 LA 12,255 Limit @SC86158 05626000 CH 12,14(1) Buffer length @SC86295 05627000 BNH *+8 Too big @SC86158 05628000 LH 12,14(1) Ok, use it @SC86295 05629000 LTR 12,12 @SC86158 05630000 BNP ICPTRET @SC86283 05631000 CR 12,15 Enough room? @SC86283 05632000 BH ICPTRET No @SC86283 05633000 ICM 15,7,9(1) Buffer address @SC86295 05634000 TM MSGFLAGS,NOTYPING @SC88309 05634100 BO ICPTRET HT is in effect @SC88309 05634200 TM 13(1),X'40' Error message? @SC88309 05634300 BZ *+8 No, keep whole text @SC88309 05634400 DIAG 15,12,X'5C' Adjust according to EMSG @SC88309 05634500 LTR 12,12 Anything to show? @SC88309 05634600 BNP ICPTRET Not anymore @SC88309 05634700 BCTR 12,0 Set up for mvc @SC86158 05635000 EX 12,SVCCOPY Move to WBUF @SC86158 05636000 LA 14,2(12,14) New end @SC86158 05637000 TM 13(1),X'80' Suppress NL? @SC88309 05637200 BZ *+6 No, keep it @SC88309 05637400 BCTR 14,0 Yes, append next line @SC88309 05637600 ST 14,SVCOPTR @SC86158 05638000 ICPTRET SR 15,15 Success @SC86283 05639000 CLM 13,8,SVCEXIT Was it an SVC? @SC86283 05640000 BE SVCDONE Yes @SC86283 05641000 LM 12,14,SVCSV1 Restore regs @SC86283 05642000 BR 14 Return @SC86283 05643000 SVCDONE L 12,SVCOPSW+4 Return adr @SC86158 05644000 CLI 0(12),0 Error adr given? @SC86158 05645000 BNE SVCRET @SC86158 05646000 LA 14,4(12) Yes, skip over @SC86158 05647000 SVCSKP STCM 14,7,SVCOPSW+5 @SC86158 05648000 SVCRET LM 12,14,SVCSV1 Restore @SC86158 05649000 SR 15,15 'success' @SC86158 05650000 LPSW SVCOPSW Return @SC86158 05651000 SVCCOPY MVC 0(,14),0(15) @SC86158 05652000 * 05653000 SVC203T L 12,SVCOPSW+4 Code ptr @SC86158 05654000 SVCABNT CLI 1(12),11 DMSABN? @SC86158 05655000 BNE SVCGO No, do it @SC86158 05656000 SVCCNCL MVC SVCNPSW,SAVENPSW Cancel interception @SC86158 05657000 MVC ADMSCWR,TYPSAV @SC86283 05658000 SVCGO MVC 0(8,0),SAVENPSW Proper SVC handler @SC86158 05659000 LM 12,15,SVCSV1 @SC86158 05660000 LPSW 0 @SC86158 05661000 * Storage for SVC interception @SC86158 05662000 SAVENPSW DS D SYSTEM SVC NPSW @SC86158 05663000 SVCSNAG DC A(0,SVCEXIT) My replacement @SC86158 05664000 SVCSV1 DS 2F Saved 12,13 @SC86158 05665000 SVCSV2 DS 2F Saved 14,15 @SC86158 05666000 SVCOPTR DS 2F Buffer output and end ptrs @SC86158 05667000 SVCOCPTR DS A Correct ptr to SVC code @SC89235 05667500 TYPSAV DS F Saved system address @SC86283 05668000 LOCALS , @SC86295 05669000 SUPFNC EXIT @SC86158 05670000 TITLE 'TERMIO Routine - Handle terminal I/O' 05671000 * R1 points to a pair of (adr,len) for read or write. If I/O is 05672000 * successfull, R15 returns transferred byte count (else returns -1). 05673000 * Command code is in R0: 05674000 * 1 => Open line for I/O 4 => Write packet 05675000 * 2 => Close line 5 => Read packet 05676000 * 3 => Reset line status after ( 6 => Write message ) not used 05677000 * environment changes 05678000 * 05679000 TERMIO ENTER 05680000 SR 15,15 OK @SC86295 05681000 BCT 0,TRMCLS @SC86295 05682000 * Open terminal line for protocol 05683000 WAITT 05684000 STAX BR14 Ingore attention interrupts 05685000 MVI RIOC,X'80' Nothing saved @SC86295 05686000 MVI TRMFLG,X'FF' Initialize w/r flag @SC87275 05687000 B TRMSPRP @SC87275 05688000 * Close terminal line after protocol transfer 05689000 TRMCLS BCT 0,TRMRSET @SC86295 05690000 STAX 05691000 B RTRN0 @SC86295 05692000 * (Re)set terminal characteristics to suit environment 05693000 TRMRSET BCT 0,TRMRW @SC86295 05694000 B RTRN0 @SC86295 05695000 * 05696000 * Perform I/O request 05697000 TRMRW BCT 0,TRMRD @SC87275 05698000 CLI WRRD,0 Write/read? @SC87275 05699000 BE TRMWO No, do it immediately @SC87275 05700000 MVC RIOPRP(8),0(1) Yes, save stuff for prompt @SC87275 05701000 B RTRN0 @SC87275 05702000 TRMWO MVI TRMFLG,0 Indicate no action on follow-up @SC87275 05703000 B TRMEX Do the write @SC87275 05704000 TRMRD TS TRMFLG @SC87275 05705000 BZ RTRN0 Just a follow-up. 0-length read @SC87275 05706000 * 05707000 TRMEX SLA 0,4 @SC87275 05708000 LA 8,TRMPLS @SC87275 05709000 AR 8,0 Get appropriate CCW skeleton @SC86295 05710000 MVC 9(3,8),1(1) Copy adr @SC86295 05711000 MVC 14(2,8),6(1) Copy len @SC86295 05712000 HOST 0(8) Issue command @SC86295 05713000 LH 15,14(8) Number of chars xfer'd @SC86295 05714000 TRMSPRP LA 0,S1EOL Reinstate "normal" prompt @SC87275 05715000 LA 1,2 @SC87275 05716000 CLI S1HND,0 Handshake desired? @SC87275 05717000 BNE *+6 Yes, ok @SC87275 05718000 BCTR 1,0 No, send just the EOL @SC87275 05719000 STM 0,1,RIOPRP @SC87275 05720000 RET @SC86295 05721000 * 05722000 TRMPLS DS 0F Terminal I/O plists @SC86295 05723000 * WRTERM Plist during Kermit protocol 05724000 DC CL8'TYPLIN' 05725000 DC X'01',AL3(*-*) Send buffer address @SC86190 05726000 DC C'B',X'92' B=Black,02=No xlate,90=Long @TB86218 05727000 DC H'0' Buffer length 05728000 * RDTERM plist during RPACK 05729000 DC CL8'WAITRD' 05730000 DC X'01',AL3(*-*) Rcv buffer addr @SC86190 05731000 DC C'*',C'B' *:long, B:prompt/direct @SC87201 05732000 DC AL2(0) Input data length 05733000 RIOPRP DC A(0,1) Prompt @SC87275 05734000 LOCALS , @SC86295 05735000 EXIT 05736000 TITLE 'SCRNIO Routine - Handle screen I/O via Series/1' 05737000 * R1 points to a pair of (adr,len) for read or write. If I/O is 05738000 * successfull, R15 returns transferred byte count (else returns -1). 05739000 * Command code is in R0: 05740000 * 0 => Clear screen on console (not comm line) @SC90045 05740500 * 1 => Open screen for I/O 4 => Write packet 05741000 * 2 => Close screen 5 => Read packet 05742000 * 3 => Reset screen status after 6 => Write message 05743000 * environment changes 05744000 * 05745000 * CCW Flags, WCC flag bits, CSW flags: 05746000 CC EQU X'40' Command chaining @SC86159 05747000 SLI EQU X'20' Suppress Incorr Len Ind 05748000 ATN EQU X'80' Attention 05749000 CE EQU X'08' Channel end 05750000 DE EQU X'04' Device end 05751000 UC EQU X'02' Unit check 05752000 UE EQU X'01' Unit exception 05753000 CPBRK EQU ATN+CE+DE+UC CP break-in 05754000 * 05755000 SCRNIO ENTER 05756000 LTR 0,0 @SC90045 05756100 BZ SCRCLR @SC90045 05756200 STC 0,CONSOPR Save command code @LP88158 05756500 BCT 0,SCRCLS @SC86295 05757000 MVC HNDFNC,HNDPAT+8 Copy function (SET) @SC88326 05758500 WAITT , Make CMS happy 05759000 HOST HNDINTPL Issue HNDINT @SC86295 05760000 LA 8,SCRCCWCL Clear screen now @SC86295 05761000 BAL 9,SCRNEX @SC86295 05762000 MVI RIOC,X'80' Nothing saved @SC86295 05763000 ICM 0,15,LCLDLY @SC87268 05764000 BZ RTRN0 Skip extra delay @SC87268 05765000 CPCMD 6,7,'SL 1 SEC' This seems useful @HF86233 05766000 B RTRN0 @SC86295 05767000 SCRCLR CLI TRMTP,C'T' Is it a TTY terminal? @SC90045 05767070 BE RTRN0 Yes, can't clear screen @SC90045 05767140 CLI TRMTP,C'V' Is it a TTY terminal? @SC90045 05767210 BE RTRN0 Yes, can't clear screen @SC90045 05767280 TM FL2,PROTO In protocol mode? @SC90045 05767350 BO RTRN0 Yes, skip clearing screen @SC90045 05767420 WAITT , Wait if necessary @SC90045 05767490 L 1,ADEVTAB Ptr to device table in nucleus @SC90045 05767560 LH 2,0(,1) CON1 is first device @SC90045 05767630 LA 1,SCRCCWCL Clear-screen CCW @SC90045 05767700 DIAG 1,2,X'58' Start I/O via diagnose @SC90045 05767770 B RTRN0 @SC90045 05767840 SCRCLS BCT 0,SCRRSET @SC86295 05768000 LA 8,SCRCCWVM Release screen @SC86295 05769000 BAL 9,SCRNEX @SC86295 05770000 MVC HNDFNC,=C'CLR ' @SC88326 05771000 HOST HNDINTPL Issue HNDINT CLR @SC88326 05771500 LA 5,=C'READY ...' Make sure hanging writes appear @SC86159 05772000 MVC 6(3,5),CONSADH Use console vaddr @SC86159 05773000 LA 7,9 String length @SC86159 05774000 CPCMD 5,7,RESP=YES Suppress reply @SC86159 05775000 B RTRN0 @SC86295 05776000 * (Re)set device characteristics to suit environment 05777000 SCRRSET BCT 0,SCRRW @SC86295 05778000 B RTRN0 05779000 * 05780000 * Perform I/O request 05781000 SCRRW MVC SCRCCW,0(1) Copy adr+len @SC88049 05782000 LR 5,0 @SC88049 05782500 CLC =C'CON1',HNDDV Console device? @SC89088 05782600 BE *+8 Yes, use DIAG 58 facility @SC89088 05782700 LA 5,3(,5) No, use alternate CCW codes @SC89088 05782800 IC 9,SCRCCM-1(5) Get command code @SC88049 05783000 STC 9,SCRCCW @SC88049 05783500 IC 9,SCRCCF-1(5) Get flags @SC88049 05784000 STC 9,SCRCCW+5 @SC88049 05784500 MVI SCRCCW+4,SLI Suppress length interrupts @SC88049 05785000 CLI CONSOPR,5 Read operation next? @SC89180 05785040 BE SCRE4TRY Yes, VTAM will be happy @SC89180 05785080 TM S1INTFL,ATN Seen attention interrupt lately? @SC89180 05785120 BZ SCRE4TRY No, VTAM will be happy @SC89180 05785160 LA 0,C'a' Yes, should see what he wants @SC89180 05785200 LA 1,CONSXSTA @SC89180 05785240 LA 2,2 @SC89180 05785280 BAL 7,SCRLOG Log the interrupt @SC89180 05785320 LA 0,5 @SC89180 05785360 KCALL SCRNIO,SCRRDPL Use recursive call to read @SC89180 05785400 SCRE4TRY LA 8,SCRCCW @LP88188 05785500 BAL 9,SCRNEX Execute internal subr @SC86295 05787000 CLI CONSOPR,5 Was it a packet read? @LP88188 05788000 BNE RTRN No, continue @LP88188 05788080 LTR 15,15 Did it fail? @LP88188 05788160 BL RTRN Yes, continue @LP88188 05788240 TM FL2,PROTO In midst of transfer? @SC88203 05788260 BZ RTRN No, must be status check @SC88203 05788280 L 1,0(8) Data address @LP88188 05788320 CLI 0(1),X'E4' 7171 overrun (line error)? @LP88188 05788400 BNE RTRN No, continue @LP88188 05788480 LA 8,SCRE4RET CCWs to reset transparent mode @LP88188 05788560 MVI CONSOPR,4 And send a dummy packet @LP88188 05788640 BAL 9,SCRNEX @LP88188 05788720 MVI CONSOPR,5 Do the read again @LP88188 05788800 B SCRE4TRY Loop until no more E4 reply @LP88188 05788880 * 05789000 SCRXCT ENABLE INTTYPE=NONE Disable all interrupts @XN89235 05790000 CLC =C'CON1',HNDDV Console device? @SC89088 05790100 BE SCRXDIAG Yes, use DIAG 58 facility @SC89088 05790200 AIF ('&KTAG' NE 'XA').CMSXA2 @SC90067 05790205 TM FLGXA,XACMS In 370/XA mode? @SC89235 05790210 BZ SCRXSIO No, do SIO @XN89235 05790220 MVC SCRORB+5(2),=X'40FF' Set various flags @XN89235 05790230 ST 1,ORBCPA Set Channel Program Address @XN89235 05790240 GETSID DEVICE=(2) Get subchannel number in R1 @XN89235 05790250 SSCH SCRORB Start the I/O operation @XN89235 05790260 BNZ SCRERR Error if not CC=0 @XN89235 05790270 B SCRXTSCH Drain the status @XN89235 05790280 SCRXSIO DS 0H @XN89235 05790290 .CMSXA2 ANOP @SC90067 05790295 LR 15,1 Note: R1 clobbered by DMSEXS @SC89166 05790300 DMSEXS ST,15,CAW Use basic SIO @SC89166 05790400 SIO 0(2) @SC89088 05790500 BNZ SCRERR I/O error case @XN89235 05790700 B SCRXTIO Drain status @XN89235 05790750 SCRXDIAG DIAG 1,2,X'58' Start I/O via diagnose @SC89088 05790800 BNZ SCRERR I/O error @XN89235 05790900 AIF ('&KTAG' NE 'XA').CMSXA3 @SC90067 05790905 TM FLGXA,XACMS In 370/XA mode? @SC89235 05790910 BZ SCRXTIO No, do TIO @SC89235 05790920 GETSID DEVICE=(2) Get subchannel number in R1 @SC89235 05790930 SCRXTSCH TSCH SCRSUBAR Test status of device @SC89235 05790940 BC 4,SCRXTSCH Loop until status pending @XN89235 05790950 BC 1,SCRERR Error if not there now ! (??) @XN89235 05790960 MVC CONSCSW(8),IRBCSW Grab status @XN89235 05790970 B SCRXTIOO Rejoin 370 mode @SC89235 05790980 .CMSXA3 ANOP @SC90067 05790985 SCRXTIO DS 0H @SC89235 05790990 TIO 0(2) Test for completion @SC89088 05791000 BNZ *-4 Keep waiting @SC89088 05791100 MVC CONSCSW(8),CSW Grab status @SC89088 05791200 SCRXTIOO DS 0H @XN89235 05791300 CLI CONSOPR,4 Doing a write/read? @SC89088 05791400 BNE SCRXOK No, we don't need any interrupts @SC89088 05791500 TM CONSUNIT,ATN Somehow already caught attention? @SC89165 05791600 BO SCRXOK Yes, don't wait at all @SC89165 05791700 HOST HNDWAIT Wait for I/O to complete @SC88326 05792000 OI CONSUNIT,ATN Signal attention seen @SC89088 05792300 SCRXOK DS 0H @SC89088 05792600 ENABLE INTTYPE=ALL Reenable interrupts @XN89235 05792800 CLI CONSCHAN,0 @LP88186 05793000 BNE SCRERR Go if ch error @LP88186 05794000 TM CONSUNIT,X'73' Any unit error? @LP88186 05795000 BNZ SCRERRC @LP88186 05796000 LA 0,C'i' "good interrupt" label @SC89166 05797000 * B SCRLOGI Log it fall through @LP88186 05798000 * 05800000 * SCRLOG: Hexadecimal log of (R2) bytes at address (R1) @LP88158 05800100 * Log label is taken from R0 low order byte. @SC89166 05800200 * Return via R7. R0-R3 and R15 destroyed. @SC89166 05800300 SCRLOGI DS 0H Special entry to log interrupts @LP88158 05800400 LA 1,CONSCSW @SC89166 05800500 LA 2,CONSTLEN @LP88158 05800600 SCRLOG TM FL1,DEBUG Logging in effect? @SC87286 05801000 BZR 7 No, that's all @SC89166 05802000 TM DBGFLG,DBGIO I/O stuff requested? @SC88168 05802300 BZR 7 No, skip it @SC89166 05802600 L 3,LOGBUF Ptr to buffer @LP88158 05802900 STC 0,0(,3) Set log label @SC89166 05803000 LA 0,6*9+2(3) End of line buffer @SC88168 05803200 LA 3,2(3) Start of data area @LP88158 05803800 SCRLOGLP MVI 0(3),C' ' Add for readability @LP88158 05804100 UNPK 1(9,3),0(5,1) Unpack into buffer @SC88168 05804400 TR 1(8,3),TRHEX Convert to printable hex @SC88168 05804700 LA 3,9(3) Advance text ptr @SC88168 05805000 LA 1,4(1) and data source @LP88158 05805300 S 2,F4 Finished data? @SC88168 05805600 BNP SCRLGEND Yes, go write @LP88158 05805900 CR 3,0 Reached text limit? @LP88158 05806200 BL SCRLOGLP no, loop for more slices @LP88158 05806500 MVC 0(3,3),=C'...' Show incomplete @LP88158 05806800 LA 3,3(3) @SC88168 05807100 SCRLGEND DS 0H @LP88158 05807400 AR 2,2 Check for incomplete slice @SC88168 05807700 BNM *+6 No, ok @SC88168 05808000 AR 3,2 Yes, adjust end of text @SC88168 05808300 S 3,LOGBUF Get length of text @SC88168 05808600 WRITF LOGPTR,BSIZE=(3) Log it @LP88158 05808900 TM DBGFLG,DBGSV SAVE requested? @SC88168 05809200 BZR 7 No, skip closing log file @SC89166 05809500 SAVEF LOGPTR Update disk directory @SC88168 05809800 BR 7 @SC89166 05810100 * 05811000 SCRNEX LA 4,10 CP BREAKIN recovery retry count @LP88186 05812000 NI S1INTFL,255-ATN Clear pending attention, if any @SC89180 05812050 SCRDIAG LR 1,8 Get CCW ptr @LP88186 05812100 SLR 2,2 Convert op. code to log label @LP88158 05812200 IC 2,CONSOPR @LP88158 05812300 LA 2,CONSOPRS(2) @LP88158 05812400 IC 0,0(,2) @SC89166 05812500 LA 2,8 Size of one CCW @LP88158 05812600 TM 4(1),CC Command chained? @LP88158 05812700 BZ *+8 @LP88158 05812800 LA 2,8(2) Yes, add another @LP88158 05812900 BAL 7,SCRLOG CCWs logged @SC89166 05813000 LH 2,CONSADDR Console address 05814000 AIF ('&KTAG' NE 'XA').CMSXA4 @SC90067 05814050 TM FLGXA,XACMS In 370/XA mode? @SC89235 05814100 BZ SCRTIO No, do TIO @SC89235 05814200 GETSID DEVICE=(2) Get subchannel number in R1 @XN89235 05814300 SCRTSCH TSCH SCRSUBAR Test status of console @XN89235 05814400 BZ SCRTSCH Loop if status stored @XN89235 05814500 B SCRTIOO Rejoin 370 mode @SC89235 05814600 SCRTIO DS 0H @SC89235 05814700 .CMSXA4 ANOP @SC90067 05814800 TIO 0(2) See if usable 05815000 BC 6,*-4 Loop if busy or CSW stored 05816000 SCRTIOO DS 0H @SC89235 05816500 BC 1,SCRERR not operational: error 05817000 LR 1,8 Copy CCW adr @SC89088 05818000 BAL 7,SCRXCT Execute and wait for completion @SC89166 05819000 LH 5,6(8) Buffer size @LP88186 05820800 SH 5,CONSBYTC Minus residual count @LP88186 05821600 L 1,0(8) Data address @LP88186 05822400 LA 0,C'd' "Data" label @SC89166 05823200 LR 2,5 Data size @LP88186 05824000 BAL 7,SCRLOG @SC89166 05824800 LR 15,5 @LP88186 05825600 TM 0(8),1 Is it a channel read? @LP88186 05826400 BOR 9 No, size OK @LP88186 05827200 S 15,F3 Deduct 3 for buffer adr @LP88186 05828000 BNLR 9 @LP88186 05828800 SLR 15,15 @LP88186 05829600 BR 9 Return to caller @LP88186 05830400 * 05831200 SCRERRC DS 0H Fatal I/O error @LP88186 05832000 LA 0,C'e' Indicate error interrupt or CC @SC89166 05832800 BAL 7,SCRLOGI Log it @SC89166 05833600 CLI CONSUNIT,CPBRK CP stole the screen? @SC89088 05834400 BNE SCRERR Bin @LP88186 05835200 BCT 4,SCRBRK Go recover unless retries exhaust @LP88186 05836000 SCRERR SR 15,15 @SC86295 05839000 BCTR 15,0 Return error code of -1 @SC86295 05840000 ENABLE INTTYPE=ALL Reenable interrupts @XN89235 05840500 BR 9 @SC86295 05841000 SCRBRK DS 0H CP BREAKIN recovery @LP88186 05842000 LA 1,RTRYIO @LP88186 05842500 LA 0,C'b' Log BREAKIN recovery CCW @SC89166 05843000 LA 2,16 @LP88186 05843500 BAL 7,SCRLOG @SC89166 05844000 LA 14,=C'RESET ...' @LP88186 05844500 MVC 6(3,14),CONSADH Use console vaddr @LP88186 05845000 LA 0,9 String length @LP88186 05845500 CPCMD 14,0,RESP=YES Reply to buffer @LP88186 05846000 LA 1,RTRYIO @LP88186 05846500 LH 2,CONSADDR Console address @LP88186 05847000 OI CONSOPR,X'80' Flag to avoid waiting for ATTN @LP88186 05850990 BAL 7,SCRXCT Take the screen back @SC89166 05852000 NI CONSOPR,X'7F' Restore as request @LP88186 05852970 B SCRDIAG Try again @SC86159 05856000 DS 0D 05857000 SCRCCWCL DC X'19',AL3(0),AL1(SLI),X'FF',AL2(1) 05858000 SCRCCWVM DC X'19',AL3(0),AL1(SLI),X'FE',AL2(1) 05859000 * 05860000 RTRYIO DC 0D'0',X'19',AL3(0),AL1(CC+SLI),X'FF',AL2(1) @SC86159 05865000 DC X'29',AL3(RTRYCM),AL1(SLI),X'90',AL2(1) @TB88078 05866000 RTRYCM DC X'&S1CMD' @LP88187 05867000 * 05867200 SCRE4RET DS 0D @LP88188 05867220 DC X'29',AL3(SCRE4LTM),AL1(SLI+CC),X'90',Y(SCRE4LTL) P88168 05867240 DC X'29',AL3(SCRE4DWR),AL1(SLI),X'00',Y(SCRE4DWL) @SC88168 05867260 SCRE4LTM DC X'40',AL1(SBA),X'4040',AL1(ICR),X'4040' Reset @SC88168 05867280 SCRE4LTL EQU *-SCRE4LTM Length of command @SC88168 05867300 SCRE4DWR DC X'C2',AL1(SBA),X'5D7F',AL1(SBA),X'000180' packet@SC88168 05867320 SCRE4DWL EQU *-SCRE4DWR Length of command @SC88168 05867340 * -DIAG58- --SIO--- @SC89268 05867400 * W R WM W R WM CCW's for send, recv, msg @SC89268 05867500 SCRCCM HTBL 29,2A,29,01,06,05 Command codes @SC89268 05867600 SCRCCF HTBL 00,80,90,00,00,00 Extra flags @SC89268 05867700 * Use x'10' flag in the writemsg CCW flag byte to @TB88078 05867830 * prohibit VM/XA DIAG58 from issuing Read Modifieds @TB88078 05867860 * to check for PA1 @TB88078 05867890 TITLE 'SETMSG Routine - controls CP breakin' 05868000 * Entry: R1 selects operation 05869000 * Exit: R15=0 if ok 05870000 * 1-> Analyze user environment, determine if suitable. 05871000 * Save quantities needed and condition line for entering commands. 05872000 * Perform any system-dependent initialization. 05873000 * 2-> Condition line for protocol transfers. 05874000 * 3-> Decondition line at end of transfer. 05875000 * 4-> System-dependent clean-up at exit. 05876000 * 5-> Reperform system-dependent initialization after SET LINE. 05877000 SETMSG ENTER ALT @SC86295 05878000 BCT 1,STM2 Go if R1 not 1, so no init 05879000 L 1,ORGR1 @SC88049 05880000 MVC KRMNAM,0(1) Copy original invoked name @SC88049 05880200 L 2,CBUF Put diag result here 05880400 LA 3,32 Get this much info 05881000 DIAG 2,3,X'00' Identify 05882000 MVC USRTAKE,16(2) Move userid to our buffer 05883000 MVC HNDINTPL(LHNDWT),HNDPAT Init HNDINT @SC88326 05883500 L 1,ASTMUSET @SC87117 05884000 MVC 8(9,1),=C'MACHINE -' @SC89235 05885000 CPCMD 2,4,'Q SET',RESP=YES @SC86148 05886000 MVC ADR,CBUF Response address for parser 05887000 ST 5,LEN Response length for parser 05888000 MVC STMSCNS(8),SCANPTR Save string ptrs @SC89235 05889000 SR 5,5 Length of previous data @SC89235 05889050 LA 8,STMMLEN-2 Descriptor list for MACHINE @SC89235 05889100 BAL 2,STMGET @SC89235 05889150 L 1,ASTMUSET @SC89235 05889200 CLI 8+8(1),C'-' Is it VM/XA? @SC89235 05889250 BE STMVMSP No, remember that @SC89235 05889300 OI FLGXA,XACP CP is VM/XA @SC89235 05889350 CLI 8+8(1),C'3' Is it in 370 mode? @SC89235 05889400 BE STMVMSP Yes, remember that @SC89235 05889450 OI FLGXA,XACMS CMS is in XA mode @SC89235 05889500 WRTERM 'This is a non-XA Kermit: set machine 370' @SC89235 05889510 B RTRN1 Too bad, give up @SC89235 05889520 STMVMSP DS 0H @SC89235 05889550 MVC 0(STMUL+STMLL,1),STMUOFF Set up pattern @SC87117 05889600 S 1,F4 Start of list: back 8, up L'SET +1@SC87117 05890000 SR 5,5 Length of previous data @SC86148 05891000 LA 8,STMLEN-2 Descriptor list @SC86148 05892000 MVC SCANPTR(8),STMSCNS Restore ptrs @SC89235 05893000 BAL 2,STMGET @SC89235 05893200 BAL 2,STMGET @SC89235 05893400 MVC SCANPTR(8),STMSCNS Restore ptrs again @SC89235 05893600 LA 4,5 Number of items in QUERY SET @SC89235 05893800 BAL 2,STMGET @SC86295 05894000 BCT 4,*-4 @SC86148 05895000 CPCMD 2,6,'Q TERM',RESP=YES @SC86148 05898000 MVC ADR,CBUF Response address for parser 05899000 ST 7,LEN Response length for parser @SC87117 05900000 LA 1,1(1) One extra: L'TERM - L'SET @SC87117 05901000 BAL 2,STMGET @SC86295 05902000 BAL 2,STMGET (if more: put S 1,F4 in loop) @SC87295 05903000 * Note: KWRKBASE is 11... @SC89268 05903500 STM 10,11,STMSAVR Save base registers @SC87117 05904000 HOST STMEXC Set up subcommand environment @SC87117 05905000 B STM5X @SC87351 05906000 DS 0F @SC87117 05907000 STMEXC DC CL8'SUBCOM',CL8'KERMIT' @SC87117 05908000 DC F'0',A(STMSUBC,0) @SC87117 05909000 * 05910000 STM2 BCT 1,STM3 Go if R1 was not 2, so not off 05911000 TM FL1,TSTF @SC86295 05912000 BO RTRN0 Just testing, don't change it @SC86295 05913000 LA 2,STMUOFF Set everything off 05916000 MVC STMUOTB,AOUTRTBL Save user's table ptrs @SC87201 05917000 MVC STMUITB,AINTRTBL @SC87201 05918000 LA 7,F0 Set to turn off translation @SC87201 05919000 LR 8,7 @SC87201 05920000 B STMD 05921000 * 05922000 STM3 BCT 1,STM4 @SC86316 05923000 L 2,ASTMUSET Restore user's settings @SC87117 05924000 LA 7,STMUITB Restore user's table ptrs @SC87201 05925000 LA 8,STMUOTB @SC87201 05926000 STMD LA 4,STMUL Length of 1st batch @SC87117 05927000 LA 5,0(2,4) Start of 2nd @SC87117 05928000 LA 6,STMSPL Length of VM/SP-only stuff @SC89235 05928100 TM FLGXA,XACP Is it VM/SP? @SC89235 05928200 BZ *+8 @SC89235 05928300 AR 2,6 No, skip that stuff @SC89235 05928400 SR 4,6 @SC89235 05928500 CPCMD 2,4 Issue a bunch of CP commands @SC87117 05929000 CLI TRMTP,C'V' FULLSCREEN mode? @SC89020 05929300 BE *+12 No, do linemode stuff @SC89020 05929600 CLI TRMTP,C'T' Fullscreen mode? @SC87166 05930000 BNE RTRN0 Yes, skip linemode stuff @CR86321 05931000 DMSEXS MVC,AINTRTBL,0(7) Restore input table @SC87201 05932000 DMSEXS MVC,AOUTRTBL,0(8) Restore output table @SC87201 05933000 LA 7,STMLL @SC87295 05934000 CPCMD 5,7,RESP=YES No, do linemode stuff @SC87295 05935000 B RTRN0 05936000 * 05937000 STM4 BCT 1,STM5 Special clean-up @SC87351 05938000 B RTRN0 Special clean-up not needed @SC87351 05939000 * 05940000 STM5 DS 0H Re-init after SET LINE @SC87351 05941000 STM5X SR 2,2 @SC86295 05942000 BCTR 2,0 @SC86295 05943000 CLI TRMLIN,C' ' External line? @SC87351 05944000 BE STM5D No, use console @SC87351 05945000 TR TRMLIN,UPCASE @SC88120 05945500 LA 5,3+1 Allow no more than 3 hex digits @SC87351 05946000 SR 2,2 Init value @SC87351 05947000 LA 1,TRMLIN Ptr to string @SC87351 05948000 STM5L CLI 0(1),C' ' Look for end of value @SC87351 05949000 BE STM5D Ok, got number @SC87351 05950000 IC 3,0(1) @SC87351 05951000 CLI 0(1),C'0' 0-9? @SC87351 05952000 BL STM5LA @SC87351 05953000 CLI 0(1),C'9' @SC87351 05954000 BH RTRN1 Bad digit @SC87351 05955000 B STM5LS Ok, use it @SC87351 05956000 STM5LA CLI 0(1),C'A' A-F? @SC87351 05957000 BL RTRN1 Bad @SC87351 05958000 CLI 0(1),C'F' @SC87351 05959000 BH RTRN1 Bad @SC87351 05960000 LA 3,9(3) OK, get in binary @SC87351 05961000 STM5LS SLL 3,28 Convert to nybble @SC87351 05962000 SLDL 2,4 @SC87351 05963000 LA 1,1(1) Keep scanning @SC88049 05963500 BCT 5,STM5L @SC87351 05964000 B RTRN1 String too long @SC87351 05965000 STM5D DIAG 2,3,X'0024' Get console flags 05966000 BO RTRN1 Bad device(?) @SC87351 05967000 CLM 3,8,=X'40' Is it a dedicated GRAF dev? @SC88203 05967300 BE *+12 Yes, ok @SC88203 05967600 CLM 3,8,=X'8020' Is this a terminal? @SC87351 05968000 BNE RTRN1 No, bad device @SC87351 05969000 MVI TRMTP,C'&KCONT' 1st assume TTY @SC88309 05969500 STH 2,CONSADDR Save console addr (CUU) 05970000 UNPK CONSADH(4),CONSADDR(3) @SC86159 05971000 TR CONSADH(3),TRHEX Save as chars @SC86159 05972000 L 5,ADEVTAB Ptr to system device table @SC88326 05972100 LA 6,DEVSIZE Size of table item @SC88326 05972200 L 7,ATABEND End of table @SC88326 05972300 CLM 2,3,0(5) Check device vaddr @SC89235 05972400 BE STM5HL Found it, use this name @SC88326 05972500 BXLE 5,6,*-8 @SC88326 05972600 LA 5,HNDPATDV-4 Not found, use default name @SC88326 05972700 STM5HL MVC HNDDV,4(5) @SC88326 05972800 MVC WAITDV,4(5) @SC88326 05972900 CLM 4,12,=X'8020' Is this a TTY? @SC86295 05973000 BE RTRN0 Yes, all set @SC88203 05974000 MVI TRMTP,C'S' Remember going via S/1 @SC87166 05975000 L 8,S1RDPL @SC88203 05975050 XC 0(9,8),0(8) Zero out buffer @SC88203 05975100 LA 0,1 @SC88203 05975150 KCALL SCRNIO Clear screen and set up @SC88203 05975200 LA 0,6 @SC88203 05975250 KCALL SCRNIO,STMS1ST Issue status request @SC88203 05975300 LA 0,5 @SC88203 05975350 KCALL SCRNIO,S1RDPL Read back status @SC88203 05975400 LA 0,2 @SC88203 05975450 KCALL SCRNIO Release screen @SC88203 05975500 CLI 0(8),X'E4' Check for Yale status response @SC88203 05975550 BE *+12 Ok, I trust @SC88294 05975600 CLI 0(8),0 Other possibility @SC88294 05975610 BNE STMGRP No, must be something else @SC88294 05975620 CLI 3(8),X'11' @SC88203 05975650 BNE STMGRP No, must be something else @SC88203 05975700 CLC =X'2B5B5B',6(8) @SC88203 05975750 BE RTRN0 Yes, all set @SC88203 05975800 STMGRP MVI TRMTP,C'G' Assume graphics device @SC88203 05975850 B RTRN0 05976000 * 05977000 * Parse CP response for token pointed by R1: <len-1> token 05978000 * On entry: R1 = ptr-8-R5 of name in user list @SC86148 05979000 * R5 = length of previous token @SC86148 05980000 * R8 = ptr to previous len-1 of name,data @SC86148 05981000 * On exit: R1,R5,R8 updated @SC86148 05982000 * value copied into user list @SC86148 05983000 * 05984000 STMGET LA 8,2(8) Point to next descriptor @SC86148 05985000 LA 1,8(5,1) Advance to next name @SC86148 05986000 IC 5,1(8) Get length of data @SC86148 05987000 STMGET1 NTOKN N=0(2) Pick next token @SC86295 05988000 CLM 7,1,0(8) Is this the same size we want? @SC86148 05989000 BNE STMGET1 Not the size we want @SC86148 05990000 EX 7,STMGETC is it right one? 05991000 BNE STMGET1 Nope, keep on looking @SC86148 05992000 AR 1,7 Space over name @SC86148 05993000 NTOKN N=0(2) Use the next token @SC86316 05994000 EX 5,STMGETM Copy value @SC86148 05995000 BR 2 @SC86295 05996000 * 05997000 STMGETC CLC 0(,1),0(6) Check token against list @SC86148 05998000 STMGETM MVC 2(,1),0(6) Save value in list @SC86148 05999000 * 06000000 * ACNT TIME -- SET @SC89235 06001000 STMLEN DC AL1(03,2,04,3) @SC89235 06001300 * MSG WNG RUN EDIT IMSG -- SET @SC89235 06001600 DC AL1(02,3,02,3,02,2,06,2,03,3) @SC89235 06001900 * SIZE SCRL -- TERM @SC89235 06002200 DC AL1(07,2,05,3) @SC89235 06002500 * 06003000 STMUOFF EQU * Start of CP commands to set all off @SC89235 06004000 DC C'SET ACNT OFF',X'15' @SC89235 06004200 DC C'SET TIMER OFF ',X'15' @SC89235 06004400 STMSPL EQU *-STMUOFF Amount to skip if VM/XA @SC89235 06004600 DC C'SET MSG OFF ',X'15' @SC89235 06004800 DC C'SET WNG OFF ',X'15' (in order of CP msgs) 06005000 DC C'SET RUN ON ',X'15' 06007000 DC C'SET LINEDIT OFF',X'15' @SC88194 06007500 DC C'SET IMSG OFF ',X'15' @SC87117 06009000 STMUL EQU *-STMUOFF @CR86321 06010000 STMLOFF DC C'TERM LINESIZE OFF' @CR86321 06012000 DC CL5' ',C'SCROLL CONT' (if more, cut to 1 sp) @SC87295 06013000 STMLL EQU *-STMUOFF-STMUL @SC87117 06014000 STMMLEN DC AL1(06,2) Descriptor for MACHINE @SC89235 06014500 TITLE 'STMSUBC Routine - subcommand environment handler' 06015000 USING STMSUBC,15 @SC87117 06016000 STMSUBC STM 14,12,12(13) Save registers @SC87117 06017000 LM 10,11,STMSAVR Get base registers @SC87117 06018000 LA 0,USNTRFLX Length of locals @SC87117 06019000 BAL 14,SUBENT Set up entry @SC87117 06020000 LR 15,KSUBBASE Recover local base register @SC89268 06021000 LR 2,0 Save ptr to EPLIST @SC87117 06022000 LA 0,RTRNUM Set to return error code @SC87117 06023000 L 1,=A(USNCMDX) All commands but QUIT @SC87117 06024000 BAL 14,LOOPS @SC87117 06025000 L KSUBBASE,=A(USNTRF) Ptr to main loop routine @SC89268 06026000 LM 15,0,4(2) Ptrs to command and end @SC87117 06027000 SR 0,15 Get length @SC87117 06028000 LA 1,CMD @SC87117 06029000 MVC 0(256,1),0(15) Copy to buffer @SC87117 06030000 OI KFLG-USNTRFSV(13),CMDC+SIGN Indicate just 1 cmd @SC87117 06031000 B LUPPRS @SC87117 06032000 TITLE 'S1INT Routine - interrupt handler' 06034000 USING S1INT,15 @SC86295 06035000 S1INT DS 0H @SC89088 06036000 STCM 3,12,CONSXSTA Save status bytes @SC89180 06037000 TM CONSXSTA,ATN Attention received? @SC89180 06038000 BZ S1IOK No, forget it @SC89180 06039000 OI S1INTFL,ATN Yes, remember it @SC89180 06040000 S1IOK SR 15,15 R15=0-> intrpt proc complete 06041000 BR 14 @SC86295 06042000 DROP 15 @SC86295 06043000 * 06044000 * HNDINT Plist for Series/1 interrupt handling 06045000 HNDPAT DC CL8'HNDINT' HNDINT plist @SC88326 06046000 DC CL4'SET' Set function 06047000 HNDPATDV DC CL4'CONK' Symbolic device (or CON1) @SC88326 06048000 DC AL4(S1INT) S1 Interrupt handler 06049000 DC AL2(9) Console address (fill in) @SC88326 06050000 DC CL2'WC' 06051000 DC 4X'FF' @SC88326 06052000 DC CL8'WAIT' @SC88326 06052050 LHNDWT EQU *-HNDPAT @SC88326 06052100 * 06052200 STMS1ST DC A(STMS1ORD,L'STMS1ORD) @SC88203 06052400 STMS1ORD DC X'C32B5BBC' WCC + Yale ASCII status request @SC88203 06052600 * 06053000 CONSCSW DS A (key + cc)(1) + CCW addr(3) 06054000 CONSUNIT DS X Unit status 06055000 CONSCHAN DS X Channel status 06056000 CONSBYTC DS H Byte count 06057000 CONSTLEN EQU *-CONSCSW End of console status log area @LP88158 06057300 * 06057310 SCRRDPL DC A(SCRSENSE,L'SCRSENSE) @SC89180 06057320 SCRSENSE DS XL10 Buffer for ATN-triggered read @SC89180 06057330 CONSXSTA DS XL2 Status bytes saved on interrupt @SC89180 06057340 S1INTFL DS X Saved interrupt flags @SC89180 06057350 * 06057400 CONSOPRS DC C'?ocswrm' Console commands labels for log @LP88186 06057500 STMSAVR DS 2F @SC88168 06057600 CONSADH DC C'...',C' ' Unpacked vaddr + pad @SC86159 06058000 LOCALS , @SC86295 06059000 SCRCCW DS D CCW for send, recv, msg @SC88049 06059500 STMSCNS DS 2F Saved scan ptrs @SC87117 06060000 AIF ('&KTAG' NE 'XA').CMSXA5 @SC90067 06060050 SCRORB DS F'0' Parameter=0 @XN89235 06060100 DS X'00,40,FF,00' Key=0, etc. @XN89235 06060200 ORBCPA DS A Address is filled in @XN89235 06060300 SCRSUBAR DS 16F Storage for TSCH @XN89235 06060400 IRBCSW EQU SCRSUBAR+4,8 @XN89235 06060500 .CMSXA5 ANOP @SC90067 06060600 CONSOPR DS XL1 Current I/O operation @SC89180 06060800 SETMSG EXIT 06061000 TITLE 'DISKIO Routine - performs disk I/O functions' 06062000 * ERRNUM unchanged unless there is a disk error. 06062500 * Function selected on entry by R0: 06063000 * 0=> unnum: R1->FAB. Return R1->buffer,R0=# and remove the sequence 06063300 * number (if any) from the buffer (used for TAKE files) 06063600 * 1=> open (in): R1->pattern FDB, R2->name. Returns R0->FAB, R1->FDB 06064000 * 2=> open (out): (same) 06065000 * 3=> test name: R2->name. Returns R1->FDB if found (else R15=1) 06066000 * 4=> close file: R1->adr(FAB). 06067000 * 5=> set up search: R1->pattern name. 06068000 * 6=> return next file in list: Returns R1->FDB + sets up FILNAM 06069000 * 7=> close search (if any). 06070000 * 8=> test CWD string: R1->string. Returns R15=0 if ok, else =1. 06071000 * 9=> read: R1->FAB. Returns R15=12 if EOF, 0 if ok; R0=# data 06072000 * 10=> write: R1->FAB. Returns R15=13 if disk full, 0 if ok. 06073000 * 11=> test space: R1->pattern FDB (has size in Kbytes), 06074000 * R2->name (used if FAB not found), R6->adr(FAB). Return R15=0 if ok. 06074500 * 12=> analyze R/W error, set ERRNUM, make EMSG: R1->FAB, TMPDW=code 06075000 * always returns R15=1 06076000 * 13=> directory info on file: R1->name. Returns R15=0 if ok. 06077000 * 14=> delete file: R1->name. Returns R15=0 if ok. 06078000 * 15=> rename file: R1->name, R2->new name. Returns R15=0 if ok. 06079000 * 16=> copy file: R1->name, R2->new name. Returns R15=0 if ok. 06080000 * 21=> save file status in directory: R1->FAB. (not used) @SC88168 06080200 * 22=> open library (in): R2->DDNAME. Return R15=0 if ok. @SC89073 06080400 * 23=> point for next read, R1->adr(FDB), R2=records to skip. @SC89218 06080600 * Return R15=0 if ok. @SC89218 06080800 DISKIO ENTER 06081000 USING FABD,3 @SC86295 06082000 SR 4,4 Signal no block assigned @SC86295 06083000 LR 5,0 @SC89073 06083010 AR 5,5 @SC89073 06083020 LH 5,DSK0(5) Get handler address @SC89073 06083030 B DSK0(5) Do the function @SC89073 06083040 DSK0 DC Y(DSKNON-DSK0,DSKOPNI-DSK0,DSKOPNO-DSK0) 0-2 @SC89073 06083050 DC Y(DSKTEST-DSK0,DSKCLOS-DSK0,DSKNSET-DSK0) 3-5 @SC89073 06083060 DC Y(DSKNXT-DSK0,DSKNSX-DSK0,DSKCWDF-DSK0) 6-8 @SC89073 06083070 DC Y(DSKER1-DSK0,DSKER1-DSK0,DSKTSP-DSK0) 9-11 @SC89073 06083080 DC Y(DSKXXX-DSK0),8Y(DSKUTL-DSK0) 12-20 @SC89073 06083090 DC 2Y(DSKER1-DSK0),Y(DSKPNT-DSK0) 21-23 @SC89218 06083100 DC 8Y(DSKER1-DSK0) Spares @SC89073 06083110 * 06083120 DSKNON DS 0H @SC89073 06083130 LR 3,1 Address FAB @SC88101 06083150 L 0,FABNORD Get length of buffer @SC88101 06083200 L 2,FDBBUFF Get ptr to buffer @SC88101 06083250 CLI FDBRCF,C'F' Fixed-length records? @SC88101 06083300 BNE DSKNONZ No, no line numbers @SC88101 06083350 CH 0,=H'80' See if F/80 @SC88101 06083400 BNE DSKNONZ No @SC88101 06083450 MVZ WLDPAT(5),75(2) See if 76-80 are all numeric @SC88101 06083500 CLC WLDPAT(5),=5C'0' @SC88101 06083550 BNE DSKNONZ No @SC88101 06083600 S 0,F8 Yes, move the end back @SC88101 06083650 DSKNONZ RETREG 0,(1,2) Return R0 and (2) as R1 @SC88218 06083700 B RTRN0 Done @SC88101 06083800 DSKOPNI DS 0H @SC88101 06083850 * 06085000 * Open for input file whose name is at (R2), FDB at (R1) 06086000 BAL 9,DSKALC Get FAB @SC86295 06087000 DSKOP0 BAL 2,DSKLKP Get FST, ADT ptrs @SC86295 06088000 BNZ DSKER1 Not found @SC86295 06089000 BAL 14,DSKVALS @SC86295 06090000 B RTRN0 @SC86295 06091000 * 06092000 * Open for output file whose name is at (R2), FDB at (R1) 06093000 DSKOPNO DS 0H @SC89073 06094000 BAL 9,DSKALC Get FAB @SC86295 06095000 BAL 2,DSKLKP Get FST, ADT ptrs @SC86295 06095100 BNZ DSKOPLR Not found, just writing new @SC87012 06095200 TM FDBFLGS,APPN+SVATT Should we keep attributes? @SC90033 06095300 BZ *+8 No @SC90033 06095400 BAL 14,DSKVALS Yes, copy old ones to FDB @SC90033 06095500 TM FDBFLGS,APPN @SC86295 06096000 BO DSKOPLR @SC90033 06097000 FSERASE FSCB=(3) @SC86295 06098000 DSKOPLR SR 0,0 @SC87012 06103000 ICM 0,3,FDBLRC File LRECL @SC87012 06104000 CLI FDBRCF,C'V' RECFM F limited to LRECL @SC88120 06105000 BNE DSKSTLR @SC88120 06105500 CLI TYPFIL,C'B' Binary? @SC88120 06106000 BE DSKSTLR Yes, always fold @SC88120 06106500 L 0,MAXLRC TEXT file, no limit @SC87012 06107000 DSKSTLR ST 0,FABLRTR Set effective record length @SC88120 06108000 B RTRN0 @SC86295 06109000 * 06110000 * Test for existence of file whose name is at (R2) 06111000 DSKTEST DS 0H @SC89073 06112000 MVC DSKSTNM,0(2) @SC86295 06113000 LA 3,DSKSTT @SC86295 06114000 B DSKOP0 Test file @SC86295 06115000 * 06116000 * Close file whose ticket is at (R1), release block 06117000 DSKCLOS DS 0H @SC89073 06118000 ICM 3,15,0(1) Get FAB ptr, if any @SC86295 06119000 BZ RTRN0 None, ignore @SC86295 06120000 XC 0(4,1),0(1) Yes, now clear ticket @SC86295 06121000 FSCLOSE FSCB=(3) @SC86295 06122000 LA 0,FABDWDS @SC86295 06123000 DMSFRET DWORDS=(0),LOC=(1) @SC86295 06124000 B RTRN0 @SC86295 06125000 * 06126000 * Point past 1st N records of file at (R1) @SC89218 06126500 DSKPNT ICM 3,15,0(1) Get ticket @SC89218 06127000 BZ RTRN1 Not open @SC89218 06127500 LA 6,1 @SC89218 06128000 AR 6,2 Rec no. = 1 + number to skip @SC89218 06128500 BNP RTRN0 Never mind @SC89218 06129000 C 6,FDBNREC File long enough? @SC89218 06129500 BH RTRN1 No, skip it @SC89218 06130000 SR 0,0 Don't mess with write point @SC89218 06130500 FSPOINT FSCB=(3),WRPNT=(0),RDPNT=(6),FORM=E @SC89218 06131000 B RTRN Return with completion code @SC89218 06131500 * 06136000 * Analyze error: packed dec. code in TMPDW 06137000 DSKXXX DS 0H @SC89073 06138000 MVI ERRNUM,ERRDIE Set Kermit error code @SC87338 06139000 L 2,EMSGP Ptr to msg buffer @SC87338 06140000 MVC 0(8,2),0(1) Copy oprn name @SC87338 06141000 MVC 8(2,2),=C'R=' @SC87338 06142000 OI TMPDW+7,15 Set zone @SC87338 06143000 UNPK 10(2,2),TMPDW Copy error code @SC87338 06144000 MVC EMSGL,F12 Length of string @SC87338 06145000 B RTRN1 @SC87338 06146000 * 06147000 * Disk utility for file(s) at (R1) and (R2) 06148000 DSKUTL SH 0,=H'13' Code-13: DIR,DEL,REN,COP @SC86316 06149000 LR 8,0 Save a copy @SC86316 06150000 SLA 0,3 @SC86295 06151000 LA 5,DSKCMDS @SC86295 06152000 AR 5,0 Ptr to command name @SC86295 06153000 LA 4,CMD Buffer for tokenized command @SC86295 06154000 MVC 0(8,4),0(5) @SC86295 06155000 LA 4,8(4) @SC86295 06156000 LR 6,1 1st file @SC86295 06157000 BAL 3,DSKUTCP @SC86295 06158000 SRA 0,4 @SC86295 06159000 BZ *+10 @SC86295 06160000 LR 6,2 2nd file @SC86295 06161000 BAL 3,DSKUTCP @SC86295 06162000 LTR 8,8 Code-13 @SC86316 06163000 BNZ *+14 Go if not LISTFILE @SC86316 06163500 MVC 0(16,4),=CL16'( DATE' @SC86295 06164000 LA 4,16(4) @SC86295 06165000 MVI 0(4),X'FF' Insert fence @SC86295 06166000 MVC 1(7,4),0(4) @SC86295 06167000 LA 0,CMD @SC86295 06168000 NI FL4,255-UCMD Not user command: already tokens @SC86295 06169000 KCALL SUPFNC,3 Execute it @SC86295 06170000 B RTRN @SC86295 06171000 * 06172000 DSKUTCP LA 7,LFID Length of name @SC86295 06173000 ICM 7,8,BLANK Blank fill @SC86295 06174000 LA 5,24 @SC86295 06175000 MVCL 4,6 Copy name and update R4 @SC86295 06176000 BR 3 @SC86295 06177000 * 06178000 DSKCMDS DC C'LISTFILE' Utility command names @SC86295 06179000 DC C'ERASE ' @SC86295 06180000 DC C'RENAME ' @SC86295 06181000 DC C'COPYFILE' @SC86295 06182000 * 06183000 * Return on error, release useless block, if any 06184000 DSKER1 LTR 1,4 Any block assigned? @SC86295 06185000 BZ RTRN1 No @SC86295 06186000 LA 0,FABDWDS Yes, release it @SC86295 06187000 DMSFRET DWORDS=(0),LOC=(1) @SC86295 06188000 B RTRN1 Flag error @SC86295 06189000 * 06190000 DSKALC LR 5,1 Save FDB ptr @SC86295 06191000 MVC DSKSTNM,0(2) @SC86295 06192000 LA 0,FABDWDS @SC86295 06193000 DMSFREE DWORDS=(0),ERR=DSKER1 @SC86295 06194000 LR 3,1 New block ptr @SC86295 06195000 LA 4,FDBD FDB pointer @SC88120 06196000 RETREG (0,3),(1,4) Return (3) as R0, (4) as R1 @SC89218 06197000 LR 4,3 Indicate we have it @SC88120 06198500 XC 0(8*FABDWDS,3),0(3) @SC86295 06199000 MVC FDBD(FDBCOP),0(5) Copy user's FDB @SC86295 06200000 MVC FABFN(18),0(2) @SC86295 06201000 OI FDBFLGS,FDBEPL @SC86295 06202000 MVI FABANIT+3,1 @SC86295 06203000 ICM 14,15,LFID(2) Get start and end for sending @SC89218 06203200 ICM 15,15,LFID+4(2) @SC89218 06203400 SLR 15,14 Length of request @SC89218 06203600 ST 15,FDBSREC Save for length computation @SC89218 06203800 BR 9 @SC86295 06204000 * 06205000 DSKLKP DMSKEY NUCLEUS @SC86295 06206000 GETFST DSKSTT Call system routine for FST @SC86295 06207000 LR 9,0 Save ADT ptr @SC86295 06208000 LR 8,1 And FST ptr @SC86295 06209000 LTR 1,15 Save return code @SC86295 06210000 DMSKEY RESET @SC86295 06211000 LTR 15,1 Test return code @SC86295 06212000 BR 2 @SC86295 06213000 * 06214000 * Set up search through list of files, pattern at (R1) 06215000 DSKNSET DS 0H @SC89073 06216000 NI DSKFL,255-CWDF Find files @SC86295 06217000 MVC NXFN(18),0(1) @SC86295 06218000 * 06218300 * Flush previous file pattern 06218600 DSKNSX MVI ADT,X'80' Start over @SC86295 06219000 B RTRN0 @SC86295 06220000 * 06225000 * Check CWD string, return code in R15 06226000 DSKCWDF DS 0H @SC89073 06227000 OI DSKFL,CWDF Find disk @SC86295 06228000 MVC NXFN(18),0(1) @SC86295 06229000 MVI ADT,X'80' Start over @SC86295 06230000 B NXTFST @SC86295 06231000 * 06232000 * Check disk space for proposed file: FDB at (R1), FAB ptr at (R6) 06233000 DSKTSP L 5,FDBSIZE-FDBD(,1) Get actual size @SC90037 06233500 ICM 3,15,0(6) Get FAB ptr @SC90037 06234000 BZ DSKTSPX Not open yet @SC90037 06234500 IC 1,FABFM Get mode letter @SC90037 06235000 DSKTSP0 DS 0H @SC90037 06235500 USING FSTSECT,8 @SC90037 06236000 USING ADTSECT,9 @SC86316 06237000 L 9,IADT Look at 1st ADT @SC86316 06238000 DSKTSP1 CLM 1,1,ADTM Find right disk @SC90037 06239000 BE DSKTSP2 @SC86316 06240000 ICM 9,15,ADTPTR Try next @SC86316 06241000 BNZ DSKTSP1 @SC86316 06242000 B RTRN0 Disk not found! @SC86316 06243000 DSKTSP2 L 1,ADTNUM Total blocks @SC86316 06244000 S 1,ADTUSED Less used @SC86316 06245000 M 0,ADTDBSIZ Times block size @SC86316 06246000 SRDA 0,10 Convert to Kbytes @SC86316 06247000 CLR 1,5 @SC90037 06248000 BL RTRN1 No room @SC86316 06249000 B RTRN0 Ok @SC86316 06250000 DSKTSPX MVC DSKSTNM,0(2) File not opened yet, look for it @SC90037 06250050 BAL 2,DSKLKP @SC90037 06250100 IC 1,DSKSTNM+FABFM-FABFN Mode letter, in case @SC90037 06250150 BNZ DSKTSP0 Not found, nothing to erase @SC90037 06250200 TM ADTFLG4,ADTEDF Extended format? @SC90037 06250250 BZ DSKTSOF @SC90037 06250300 L 1,ADTDBSIZ Block size @SC90037 06250350 M 0,FSTADBC Number of blocks @SC90037 06250400 B DSKTSS @SC90037 06250450 DSKTSOF SR 0,0 @SC90037 06250500 LA 1,800 Block size @SC90037 06250550 MH 1,FSTDBC @SC90037 06250600 DSKTSS SRDA 0,10 Convert to kbytes @SC90037 06250650 SR 5,1 Assume old file will be erased @SC90037 06250700 BNP RTRN0 Will release enough for new file @SC90037 06250750 B DSKTSP2 Not enough, check free blocks @SC90037 06250800 * 06251000 * NXTFST Routine - searches the ADT and FST chains 06252000 DSKNXT DS 0H @SC89073 06253000 * Carl Kass and Jeff Damens, CUCCA User Services, 12/80 06254000 * Modified for Kermit-CMS by Vace Kundakci, 12/85 06255000 * Copyright (C) 1980 Columbia University 06256000 * Permission is granted to any individual or institution to copy 06257000 * or use this program, except for explicitly commercial purposes. 06258000 * 06259000 * NXFN,-FT,-FM contain a CMS fileid, possibly containing wildcard 06260000 * characters, and FST and ADT contain pointers to a valid ADT & FST 06261000 * or are null (negative ADT), return the next FST matching the given 06262000 * filename in FST and the address of the corresponding ADT in ADT. 06263000 * Also move the matched filename into FN, FT, FM. 06264000 * Also return info in a File Descriptor Block @SC86151 06265000 * 06266000 USING DCHSECT,1 06268000 NXTFST ICM 9,15,ADT Supplied ADT 06269000 BP NXFNEXT Use it if there's one 06270000 L 9,IADT Else, start with first ADT @SC86295 06271000 NI DSKFL,255-WFM-WFT-WFN Nothing wild yet 06272000 LA 3,NXFN @SC86295 06273000 BAL 14,NXFPAT @SC86295 06274000 OI DSKFL,WFN @SC86295 06275000 LA 3,NXFT @SC86295 06276000 BAL 14,NXFPAT @SC86295 06277000 OI DSKFL,WFT @SC86295 06278000 CLI NXFM,C'A' @SC86115 06279000 BNL NXFAFM Go if mode letter is A or more 06280000 MVI NXFM,C'%' Set to % if it was blank @SC86115 06281000 OI DSKFL,WFM 06282000 NXFAFM CLI NXFM+1,C'0' @SC86115 06283000 BNL NXFADT Go if mode number is numeric 06284000 MVI NXFM+1,C'%' Set to % if was blank or * @SC86115 06285000 NXFADT TM ADTFLG1,ADTFRO+ADTFRW 06286000 BZ NXFNADT 06287000 CLI NXFM,C'%' @SC86115 06288000 BE NXFFFST Go if he can use any 06289000 CLC ADTM,NXFM 06290000 BE NXFFFST Go if it is this disk 06291000 TM DSKFL,CWDF Called for CWD? @SC86295 06292000 BO NXFNADT Just looking for disk @SC86222 06293000 CLC ADTMX,NXFM Check for read-only extension @SC86222 06294000 BE NXFFFST Yes, search here too @SC86222 06295000 NXFNADT ICM 9,15,ADTPTR Use next ADT @SC86295 06296000 BNZ NXFADT But ony if it exists 06297000 NXFER MVI ADT,255 For next time, start all over 06298000 B RTRN1 Bad return code @SC86295 06299000 * 06300000 NXFPAT LA 1,8(3) End addr of FN or FT @SC86295 06301000 TRT 0(8,3),TRTBL Look for space @SC86295 06302000 SR 1,3 Compute length @SC86295 06303000 ST 1,NXFFNL-NXFN(3) Length of pattern @SC86295 06304000 MVI TRTBL+C' ',0 Don't want to catch a blank @SC86115 06305000 MVI TRTBL+C'%',1 Want to catch a percent @SC86115 06306000 MVI TRTBL+C'*',1 Want to catch an asterisk @SC86115 06307000 TRT 0(8,3),TRTBL See if any % or * in FN @SC86295 06308000 MVI TRTBL+C'%',0 Restore TRTBL @SC86115 06309000 MVI TRTBL+C'*',0 @SC86115 06310000 MVI TRTBL+C' ',1 @SC86115 06311000 BZ 4(14) No wild chars found @SC86295 06312000 BR 14 @SC86295 06313000 * 06314000 NXFFFST L 1,ADTFDA Grab hyperblock ptr 06315000 TM DSKFL,CWDF Called for CWD? @SC86295 06316000 BO NXFHSV Yes, found it @SC86164 06317000 NXFHYP ST 1,NXFHYPE Save for later 06318000 LA 8,DCHDATA Point to first FST 06319000 L 3,DCHDWSIZ Get size of hyperblock 06320000 SLL 3,3 Convert to bytes 06321000 LA 2,DCHSECT(3) Add to get end of hyperblk 06322000 ST 2,NXFHEND Save it 06323000 * 06324000 * All initialized. Ready to step through files. R8 contains current 06325000 * FST, R9 contains current ADT, NXFHYPE contains current hyperblock 06326000 * NXFHEND has end of hyperblock. 06327000 * 06328000 NXFFST CLC F0,FSTN 06329000 BE NXFNHYP Go try next hyperblock 06330000 CLC F0,FSTN+4 06331000 BE NXFNFST Go if directory or Alocmap 06332000 LA 4,NXFN @SC86295 06333000 LA 5,FSTN @SC86295 06334000 TM DSKFL,WFN @SC86295 06335000 BAL 14,NXFCOMP Test pattern against token @SC86295 06336000 LA 4,NXFT @SC86295 06337000 LA 5,FSTT @SC86295 06338000 TM DSKFL,WFT @SC86295 06339000 BAL 14,NXFCOMP Test pattern against token @SC86295 06340000 * 06341000 CLI NXFM+1,C'%' @SC86115 06342000 BE NXFHAVE Go if any FM is ok 06343000 CLC NXFM+1(1),FSTM+1 @SC86295 06344000 BNE NXFNFST Go if no match 06345000 NXFHAVE MVC FN,FSTN Return FN @SC86164 06346000 MVC FT,FSTT Return FT 06347000 MVC FM+1(1),FSTM+1 Return FM number 06348000 LA 3,DSKSTT @SC86295 06349000 MVC FDBSREC,F0 Length request not known @SC89218 06349500 BAL 14,DSKVALS Copy out quantities @SC86295 06350000 NXFHSV MVC FM(1),ADTM Return FM letter @SC86164 06351000 ST 9,ADT Save ADT for him @SC86295 06352000 ST 8,FST Ditto for FST @SC86164 06353000 B RTRN0 @SC86295 06354000 * 06355000 * Come to NXFNFST to step to next file. 06356000 * 06357000 NXFNEXT L 8,FST 06358000 NXFNFST TM ADTFLG4,ADTEDF 06359000 BZ NXFNEDF Go if not EDF 06360000 LA 8,FSTL2(8) Point to next EDF FST 06361000 B NXFEDF 06362000 * 06363000 NXFNEDF LA 8,FSTL(8) Point to next non-EDF FST 06364000 NXFEDF C 8,NXFHEND End of hyperblock? 06365000 BL NXFFST No, there are more FSTs still 06366000 NXFNHYP L 1,NXFHYPE Point to current hyperblock 06367000 ICM 1,B'1111',DCHFWPTR Next hyperblock 06368000 BNZ NXFHYP Go use next hyperblock if any 06369000 B NXFNADT Need to use next disk 06370000 * 06371000 DSKVALS LA 0,FDBD Ptr to FDB @SC86295 06372000 RETREG (1,0) Return (0) as R1 to caller @SC89218 06373000 NI DSKFL,255-WARB @SC86295 06375000 TM ADTFLG4,ADTEDF Extended format? @SC86149 06376000 BZ DSKVNEF @SC86149 06377000 L 1,ADTDBSIZ Block size @SC86149 06378000 M 0,FSTADBC Number of blocks @SC86149 06379000 L 7,FSTAIC Get item count @SC86239 06380000 MVC FDBDATE+1(6),FSTADATI Copy file date/time @SC88235 06381000 B DSKVEF @SC86149 06382000 DSKVNEF SR 0,0 @SC86149 06383000 LA 1,800 Block size @SC86149 06384000 MH 1,FSTDBC @SC86149 06385000 LH 7,FSTIC Get item count @SC86239 06386000 PACK FDBDATE+1(2),FSTYR(3) Copy file year @SC86295 06387000 MVC FDBDATE+2(4),FSTD Copy file date/time @SC88235 06388000 DSKVEF SRDA 0,10 Convert to kbytes @SC86149 06389000 ST 7,FDBNREC Save number of records @SC89218 06389100 ICM 6,15,FDBSREC Length requested to send @SC89218 06389200 BZ DSKVFLN Not known @SC89218 06389300 CLR 7,6 Use min @SC89218 06389400 BNH *+6 @SC89218 06389500 LR 7,6 @SC89218 06389600 DSKVFLN DS 0H @SC89218 06389700 M 6,FSTIL Compute byte count (approx. if V) @SC86239 06390000 AL 7,=F'1023' Round up @SC87007 06391000 BC 12,*+8 No overflow @SC88092 06392000 LA 6,1(6) @SC86239 06393000 SRDA 6,10 @SC86239 06394000 CLR 1,7 Compare with official length @SC86239 06395000 BL *+6 @SC86239 06396000 LR 1,7 Use computed length instead @SC86239 06397000 LTR 1,1 @SC86239 06398000 BNZ *+8 @SC86239 06399000 LA 1,1 Never say zero length @SC86239 06400000 ST 1,FDBSIZE File size @SC86295 06401000 MVI FDBDATE,X'19' Assume 20th Cent @SC86295 06402000 CLI FDBDATE+1,X'50' @SC86295 06403000 BH *+8 Ok @SC86295 06404000 MVI FDBDATE,X'20' Must be 21st @SC86295 06405000 MVC FDBRCF,FSTFV Copy format @SC86295 06406000 MVC FDBLRC,FSTIL+2 No, copy from FST @SC86295 06407000 LR 7,14 @SC86295 06408000 SR 0,0 Search from start @SC86295 06409000 LR 1,3 Filename in FAB @SC86295 06410000 A 13,F8 Preserve chain ptr in save area @SC86295 06411000 L 15,AACTLKP Find if active file @SC86295 06412000 BALR 14,15 @SC86295 06413000 S 13,F8 Resume ptr to save area @SC86295 06414000 LTR 15,15 Is it active? @SC86295 06415000 BNZR 7 @SC86295 06416000 OI FDBFLGS,FDBACTV Yes @SC86295 06417000 BR 7 @SC86295 06418000 * 06423000 DROP 1,8,9 @SC86295 06424000 * 06425000 NXFCOMP MVC NXFSTR,0(5) Copy name in @SC86295 06426000 BO NXFWF Go if wild FN or FT @SC86295 06427000 CLC NXFSTR,0(4) @SC86295 06428000 BNE NXFNFST Go if no match @SC86295 06429000 BR 14 @SC86295 06430000 * 06431000 NXFWF LA 1,8(5) Assume end @SC86295 06432000 TRT 0(8,5),TRTBL Look for first non-space @SC86295 06433000 SR 1,5 Compute length @SC86295 06434000 LR 7,1 Save length @SC86295 06435000 L 5,NXFFNL-NXFN(4) @SC86295 06436000 LA 6,NXFSTR @SC86295 06437000 * 06438000 * Enter here with R4-R7 containing: 06439000 * pattern address and length 06440000 * source address and length 06441000 * 06442000 NI DSKFL,255-WARB Haven't seen any of these @SC86295 06443000 ICM 7,B'1000',ASTER Use * as the fill char 06444000 WLDLOOP CLCL 4,6 Compare them 06445000 BER 14 They're equal, fine @SC86295 06446000 * 06447000 * String mismatch - so examine offending pattern character. If not 06448000 * % or * and we haven't seen any * yet, we fail. If it's % we just 06449000 * skip it; if it's * we skip it and remember we've seen it. Else 06450000 * back up to one past the last * and try again. 06451000 * 06452000 CLI 0(4),C'%' @SC86115 06453000 BE WLDLEN1 Go if % = LEN(1) pattern 06454000 CLI 0(4),C'*' @SC86115 06455000 BE WLDARB Go if * = ARB pattern 06456000 TM DSKFL,WARB @SC86295 06457000 BZ NXFNFST Go if ARB already seen @SC86295 06458000 CLM 7,B'0111',F0 More data to compare? 06459000 BE NXFNFST Go if exhausted @SC86295 06460000 LM 4,7,WLDPAT Restore addr of old ARB char 06461000 LA 6,1(6) Push one past 06462000 BCTR 7,0 Decrement length 06463000 STM 6,7,WLDSRC Store changed addr 06464000 B WLDLOOP And go compare again. 06465000 * 06466000 WLDLEN1 LA 4,1(4) Increment pattern addr 06467000 BCTR 5,0 Decrement pattern len 06468000 CLM 7,7,F0 Length to compare more @SC86119 06469000 BE NXFNFST None, pattern '%' is extra @SC86119 06470000 LA 6,1(6) Increment source addr 06471000 BCTR 7,0 Decrement source len 06472000 CLM 7,7,F0 Length to compare more @SC86119 06473000 BNE WLDLOOP Go if more data 06474000 LTR 5,5 Anything more in pattern? 06475000 BZR 14 No, it's a match @SC86295 06476000 CLI 0(4),C'*' @SC86115 06477000 BE WLDLOOP Go if ARB 06478000 B NXFNFST Failed @SC86295 06479000 * 06480000 * If pattern ends in ARB, then it will match anything. So return to 06481000 * caller if the pattern is exhausted. 06482000 * 06483000 WLDARB OI DSKFL,WARB Remember we saw one @SC86295 06484000 LA 4,1(4) Pass the ARB 06485000 BCTR 5,0 Decrement its length 06486000 LTR 5,5 Any more left? 06487000 BZR 14 No, it's a match @SC86295 06488000 STM 4,7,WLDPAT Save where they were 06489000 B WLDLOOP 06490000 * 06491000 LOCALS , @SC86295 06492000 WLDPAT DS A Place in pattern of last ARB 06493000 DS F Length of pattern past ARB 06494000 WLDSRC DS A Place in source when ARB seen 06495000 DS F Length of source past WLDSRC 06496000 * 06497000 WILD EXIT 06498000